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 "definable.h"
11#include "flang/Common/indirection.h"
12#include "flang/Evaluate/expression.h"
13#include "flang/Parser/message.h"
14#include "flang/Parser/parse-tree.h"
15#include "flang/Parser/tools.h"
16#include "flang/Semantics/expression.h"
17#include "flang/Semantics/tools.h"
18
19namespace Fortran::semantics {
20
21class CriticalBodyEnforce {
22public:
23 CriticalBodyEnforce(
24 SemanticsContext &context, parser::CharBlock criticalSourcePosition)
25 : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}
26 std::set<parser::Label> labels() { return labels_; }
27 template <typename T> bool Pre(const T &) { return true; }
28 template <typename T> void Post(const T &) {}
29
30 template <typename T> bool Pre(const parser::Statement<T> &statement) {
31 currentStatementSourcePosition_ = statement.source;
32 if (statement.label.has_value()) {
33 labels_.insert(*statement.label);
34 }
35 return true;
36 }
37
38 // C1118
39 void Post(const parser::ReturnStmt &) {
40 context_
41 .Say(currentStatementSourcePosition_,
42 "RETURN statement is not allowed in a CRITICAL construct"_err_en_US)
43 .Attach(criticalSourcePosition_, GetEnclosingMsg());
44 }
45 void Post(const parser::ExecutableConstruct &construct) {
46 if (IsImageControlStmt(construct)) {
47 context_
48 .Say(currentStatementSourcePosition_,
49 "An image control statement is not allowed in a CRITICAL"
50 " construct"_err_en_US)
51 .Attach(criticalSourcePosition_, GetEnclosingMsg());
52 }
53 }
54
55private:
56 parser::MessageFixedText GetEnclosingMsg() {
57 return "Enclosing CRITICAL statement"_en_US;
58 }
59
60 SemanticsContext &context_;
61 std::set<parser::Label> labels_;
62 parser::CharBlock currentStatementSourcePosition_;
63 parser::CharBlock criticalSourcePosition_;
64};
65
66class ChangeTeamBodyEnforce {
67public:
68 ChangeTeamBodyEnforce(
69 SemanticsContext &context, parser::CharBlock changeTeamSourcePosition)
70 : context_{context}, changeTeamSourcePosition_{changeTeamSourcePosition} {
71 }
72 std::set<parser::Label> labels() { return labels_; }
73 template <typename T> bool Pre(const T &) { return true; }
74 template <typename T> void Post(const T &) {}
75
76 template <typename T> bool Pre(const parser::Statement<T> &statement) {
77 currentStatementSourcePosition_ = statement.source;
78 if (statement.label.has_value()) {
79 labels_.insert(*statement.label);
80 }
81 return true;
82 }
83
84 void Post(const parser::ReturnStmt &) {
85 context_
86 .Say(currentStatementSourcePosition_,
87 "RETURN statement is not allowed in a CHANGE TEAM construct"_err_en_US)
88 .Attach(
89 changeTeamSourcePosition_, "Enclosing CHANGE TEAM construct"_en_US);
90 }
91
92private:
93 SemanticsContext &context_;
94 std::set<parser::Label> labels_;
95 parser::CharBlock currentStatementSourcePosition_;
96 parser::CharBlock changeTeamSourcePosition_;
97};
98
99template <typename T>
100static void CheckTeamType(
101 SemanticsContext &context, const T &x, bool mustBeVariable = false) {
102 if (const auto *expr{GetExpr(context, x)}) {
103 if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {
104 context.Say(parser::FindSourceLocation(x), // C1114
105 "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
106 } else if (mustBeVariable && !IsVariable(*expr)) {
107 context.Say(parser::FindSourceLocation(x),
108 "Team must be a variable in this context"_err_en_US);
109 }
110 }
111}
112
113static void CheckTeamStat(
114 SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {
115 const parser::Variable &var{stat.v.thing.thing.value()};
116 if (parser::GetCoindexedNamedObject(var)) {
117 context.Say(parser::FindSourceLocation(var), // C931
118 "Image selector STAT variable must not be a coindexed "
119 "object"_err_en_US);
120 }
121}
122
123static void CheckCoindexedStatOrErrmsg(SemanticsContext &context,
124 const parser::StatOrErrmsg &statOrErrmsg, const std::string &listName) {
125 auto CoindexedCheck{[&](const auto &statOrErrmsg) {
126 if (const auto *expr{GetExpr(context, statOrErrmsg)}) {
127 if (ExtractCoarrayRef(expr)) {
128 context.Say(parser::FindSourceLocation(statOrErrmsg), // C1173
129 "The stat-variable or errmsg-variable in a %s may not be a coindexed object"_err_en_US,
130 listName);
131 }
132 }
133 }};
134 Fortran::common::visit(CoindexedCheck, statOrErrmsg.u);
135}
136
137static void CheckSyncStat(SemanticsContext &context,
138 const parser::StatOrErrmsg &statOrErrmsg, bool &gotStat, bool &gotMsg) {
139 common::visit(
140 common::visitors{
141 [&](const parser::StatVariable &stat) {
142 if (gotStat) {
143 context.Say( // C1172
144 "The stat-variable in a sync-stat-list may not be repeated"_err_en_US);
145 }
146 gotStat = true;
147 },
148 [&](const parser::MsgVariable &var) {
149 WarnOnDeferredLengthCharacterScalar(context, GetExpr(context, var),
150 var.v.thing.thing.GetSource(), "ERRMSG=");
151 if (gotMsg) {
152 context.Say( // C1172
153 "The errmsg-variable in a sync-stat-list may not be repeated"_err_en_US);
154 }
155 gotMsg = true;
156 },
157 },
158 statOrErrmsg.u);
159
160 CheckCoindexedStatOrErrmsg(context, statOrErrmsg, "sync-stat-list");
161}
162
163static void CheckSyncStatList(
164 SemanticsContext &context, const std::list<parser::StatOrErrmsg> &list) {
165 bool gotStat{false}, gotMsg{false};
166 for (const parser::StatOrErrmsg &statOrErrmsg : list) {
167 CheckSyncStat(context, statOrErrmsg, gotStat, gotMsg);
168 }
169}
170
171static void CheckEventVariable(
172 SemanticsContext &context, const parser::EventVariable &eventVar) {
173 if (const auto *expr{GetExpr(context, eventVar)}) {
174 if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
175 context.Say(parser::FindSourceLocation(eventVar),
176 "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
177 }
178 }
179}
180
181void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
182 CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
183 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
184 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
185}
186
187void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) {
188 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
189}
190
191void CoarrayChecker::Leave(const parser::SyncAllStmt &x) {
192 CheckSyncStatList(context_, x.v);
193}
194
195void CoarrayChecker::Leave(const parser::SyncImagesStmt &x) {
196 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
197 const auto &imageSet{std::get<parser::SyncImagesStmt::ImageSet>(x.t)};
198 if (const auto *intExpr{std::get_if<parser::IntExpr>(&imageSet.u)}) {
199 if (const auto *expr{GetExpr(context_, *intExpr)}) {
200 if (expr->Rank() > 1) {
201 context_.Say(parser::FindSourceLocation(imageSet), // C1174
202 "An image-set that is an int-expr must be a scalar or a rank-one array"_err_en_US);
203 }
204 if (const auto *someInt{
205 std::get_if<evaluate::Expr<evaluate::SomeInteger>>(&expr->u)};
206 someInt && evaluate::IsActuallyConstant(*someInt)) {
207 auto converted{evaluate::Fold(context_.foldingContext(),
208 evaluate::ConvertToType<evaluate::SubscriptInteger>(
209 common::Clone(*someInt)))};
210 if (const auto *cst{
211 evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
212 converted)}) {
213 for (auto elt : cst->values()) {
214 auto n{elt.ToInt64()};
215 if (n < 1) {
216 context_.Say(parser::FindSourceLocation(imageSet),
217 "Image number %jd in the image-set is not valid"_err_en_US,
218 std::intmax_t{n});
219 break;
220 }
221 }
222 }
223 }
224 }
225 }
226}
227
228void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) {
229 CheckSyncStatList(context_, x.v);
230}
231
232void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
233 CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
234 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
235}
236
237static void CheckEventWaitSpecList(SemanticsContext &context,
238 const std::list<parser::EventWaitSpec> &eventWaitSpecList) {
239 bool gotStat{false}, gotMsg{false}, gotUntil{false};
240 for (const parser::EventWaitSpec &eventWaitSpec : eventWaitSpecList) {
241 common::visit(
242 common::visitors{
243 [&](const parser::ScalarIntExpr &untilCount) {
244 if (gotUntil) {
245 context.Say( // C1178
246 "Until-spec in a event-wait-spec-list may not be repeated"_err_en_US);
247 }
248 gotUntil = true;
249 },
250 [&](const parser::StatOrErrmsg &statOrErrmsg) {
251 common::visit(
252 common::visitors{
253 [&](const parser::StatVariable &stat) {
254 if (gotStat) {
255 context.Say( // C1178
256 "A stat-variable in a event-wait-spec-list may not be repeated"_err_en_US);
257 }
258 gotStat = true;
259 },
260 [&](const parser::MsgVariable &var) {
261 WarnOnDeferredLengthCharacterScalar(context,
262 GetExpr(context, var),
263 var.v.thing.thing.GetSource(), "ERRMSG=");
264 if (gotMsg) {
265 context.Say( // C1178
266 "A errmsg-variable in a event-wait-spec-list may not be repeated"_err_en_US);
267 }
268 gotMsg = true;
269 },
270 },
271 statOrErrmsg.u);
272 CheckCoindexedStatOrErrmsg(
273 context, statOrErrmsg, "event-wait-spec-list");
274 },
275
276 },
277 eventWaitSpec.u);
278 }
279}
280
281void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
282 const auto &notifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};
283
284 if (const auto *expr{GetExpr(context_, notifyVar)}) {
285 if (ExtractCoarrayRef(expr)) {
286 context_.Say(parser::FindSourceLocation(notifyVar), // F2023 - C1178
287 "A notify-variable in a NOTIFY WAIT statement may not be a coindexed object"_err_en_US);
288 } else if (!IsNotifyType(evaluate::GetDerivedTypeSpec(
289 expr->GetType()))) { // F2023 - C1177
290 context_.Say(parser::FindSourceLocation(notifyVar),
291 "The notify-variable must be of type NOTIFY_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
292 } else if (!evaluate::IsCoarray(*expr)) { // F2023 - C1612
293 context_.Say(parser::FindSourceLocation(notifyVar),
294 "The notify-variable must be a coarray"_err_en_US);
295 }
296 }
297
298 CheckEventWaitSpecList(
299 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
300}
301
302void CoarrayChecker::Leave(const parser::EventPostStmt &x) {
303 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
304 CheckEventVariable(context_, std::get<parser::EventVariable>(x.t));
305}
306
307void CoarrayChecker::Leave(const parser::EventWaitStmt &x) {
308 const auto &eventVar{std::get<parser::EventVariable>(x.t)};
309
310 if (const auto *expr{GetExpr(context_, eventVar)}) {
311 if (ExtractCoarrayRef(expr)) {
312 context_.Say(parser::FindSourceLocation(eventVar), // C1177
313 "A event-variable in a EVENT WAIT statement may not be a coindexed object"_err_en_US);
314 } else {
315 CheckEventVariable(context_, eventVar);
316 }
317 }
318
319 CheckEventWaitSpecList(
320 context_, std::get<std::list<parser::EventWaitSpec>>(x.t));
321}
322
323static void CheckLockVariable(
324 SemanticsContext &context, const parser::LockVariable &lockVar) {
325 if (const SomeExpr * expr{GetExpr(lockVar)}) {
326 if (auto dyType{expr->GetType()}) {
327 auto at{parser::FindSourceLocation(lockVar)};
328 if (dyType->category() != TypeCategory::Derived ||
329 dyType->IsUnlimitedPolymorphic() ||
330 !IsLockType(&dyType->GetDerivedTypeSpec())) {
331 context.Say(at,
332 "Lock variable must have type LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);
333 } else if (auto whyNot{WhyNotDefinable(at, context.FindScope(at),
334 {DefinabilityFlag::DoNotNoteDefinition,
335 DefinabilityFlag::AllowEventLockOrNotifyType},
336 *expr)}) {
337 whyNot->set_severity(parser::Severity::Because);
338 context.Say(at, "Lock variable is not definable"_err_en_US)
339 .Attach(std::move(*whyNot));
340 }
341 }
342 }
343}
344
345void CoarrayChecker::Leave(const parser::LockStmt &x) {
346 CheckLockVariable(context_, std::get<parser::LockVariable>(x.t));
347 bool gotAcquired{false}, gotStat{false}, gotMsg{false};
348 for (const parser::LockStmt::LockStat &lockStat :
349 std::get<std::list<parser::LockStmt::LockStat>>(x.t)) {
350 if (const auto *statOrErrmsg{
351 std::get_if<parser::StatOrErrmsg>(&lockStat.u)}) {
352 CheckSyncStat(context_, *statOrErrmsg, gotStat, gotMsg);
353 } else {
354 CHECK(std::holds_alternative<
355 parser::Scalar<parser::Logical<parser::Variable>>>(lockStat.u));
356 if (gotAcquired) {
357 context_.Say(parser::FindSourceLocation(lockStat),
358 "Multiple ACQUIRED_LOCK specifiers"_err_en_US);
359 } else {
360 gotAcquired = true;
361 }
362 }
363 }
364}
365
366void CoarrayChecker::Leave(const parser::UnlockStmt &x) {
367 CheckLockVariable(context_, std::get<parser::LockVariable>(x.t));
368 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
369}
370
371void CoarrayChecker::Leave(const parser::CriticalStmt &x) {
372 CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t));
373}
374
375void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
376 for (const auto &imageSelectorSpec :
377 std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
378 if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
379 &imageSelectorSpec.u)}) {
380 CheckTeamStat(context_, *stat);
381 }
382 }
383}
384
385void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
386 CheckTeamType(
387 context_, std::get<parser::TeamVariable>(x.t), /*mustBeVariable=*/true);
388 for (const auto &spec :
389 std::get<std::list<parser::FormTeamStmt::FormTeamSpec>>(x.t)) {
390 if (const auto *statOrErrmsg{std::get_if<parser::StatOrErrmsg>(&spec.u)}) {
391 CheckCoindexedStatOrErrmsg(
392 context_, *statOrErrmsg, "form-team-spec-list");
393 }
394 }
395}
396
397void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
398 auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
399 const parser::Block &block{std::get<parser::Block>(x.t)};
400 CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
401 parser::Walk(block, criticalBodyEnforce);
402 parser::Walk(std::get<parser::Statement<parser::EndCriticalStmt>>(x.t),
403 criticalBodyEnforce);
404 LabelEnforce criticalLabelEnforce{
405 context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
406 parser::Walk(block, criticalLabelEnforce);
407}
408
409void CoarrayChecker::Enter(const parser::ChangeTeamConstruct &x) {
410 auto &changeTeamStmt{
411 std::get<parser::Statement<parser::ChangeTeamStmt>>(x.t)};
412 const parser::Block &block{std::get<parser::Block>(x.t)};
413 ChangeTeamBodyEnforce changeTeamBodyEnforce{context_, changeTeamStmt.source};
414 parser::Walk(block, changeTeamBodyEnforce);
415 parser::Walk(std::get<parser::Statement<parser::EndChangeTeamStmt>>(x.t),
416 changeTeamBodyEnforce);
417 LabelEnforce changeTeamLabelEnforce{context_, changeTeamBodyEnforce.labels(),
418 changeTeamStmt.source, "CHANGE TEAM"};
419 parser::Walk(block, changeTeamLabelEnforce);
420}
421
422// Check that coarray names and selector names are all distinct.
423void CoarrayChecker::CheckNamesAreDistinct(
424 const std::list<parser::CoarrayAssociation> &list) {
425 std::set<parser::CharBlock> names;
426 auto getPreviousUse{
427 [&](const parser::Name &name) -> const parser::CharBlock * {
428 auto pair{names.insert(name.source)};
429 return !pair.second ? &*pair.first : nullptr;
430 }};
431 for (const auto &assoc : list) {
432 const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
433 const auto &selector{std::get<parser::Selector>(assoc.t)};
434 const auto &declName{std::get<parser::Name>(decl.t)};
435 if (context_.HasError(declName)) {
436 continue; // already reported an error about this name
437 }
438 if (auto *prev{getPreviousUse(declName)}) {
439 Say2(declName.source, // C1113
440 "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
441 *prev, "Previous use of '%s'"_en_US);
442 }
443 // ResolveNames verified the selector is a simple name
444 const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
445 if (name) {
446 if (auto *prev{getPreviousUse(*name)}) {
447 Say2(name->source, // C1113, C1115
448 "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
449 *prev, "Previous use of '%s'"_en_US);
450 }
451 }
452 }
453}
454
455void CoarrayChecker::Say2(const parser::CharBlock &name1,
456 parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
457 parser::MessageFixedText &&msg2) {
458 context_.Say(name1, std::move(msg1), name1)
459 .Attach(name2, std::move(msg2), name2);
460}
461} // namespace Fortran::semantics
462

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