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 | |
19 | namespace Fortran::semantics { |
20 | |
21 | class CriticalBodyEnforce { |
22 | public: |
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 | |
55 | private: |
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 | |
66 | class ChangeTeamBodyEnforce { |
67 | public: |
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 | |
92 | private: |
93 | SemanticsContext &context_; |
94 | std::set<parser::Label> labels_; |
95 | parser::CharBlock currentStatementSourcePosition_; |
96 | parser::CharBlock changeTeamSourcePosition_; |
97 | }; |
98 | |
99 | template <typename T> |
100 | static 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 | |
113 | static 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 | |
123 | static 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 | |
137 | static 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 | |
163 | static 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 | |
171 | static 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 | |
181 | void 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 | |
187 | void CoarrayChecker::Leave(const parser::EndChangeTeamStmt &x) { |
188 | CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t)); |
189 | } |
190 | |
191 | void CoarrayChecker::Leave(const parser::SyncAllStmt &x) { |
192 | CheckSyncStatList(context_, x.v); |
193 | } |
194 | |
195 | void 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 | |
228 | void CoarrayChecker::Leave(const parser::SyncMemoryStmt &x) { |
229 | CheckSyncStatList(context_, x.v); |
230 | } |
231 | |
232 | void 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 | |
237 | static 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 | |
281 | void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) { |
282 | const auto ¬ifyVar{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 | |
302 | void 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 | |
307 | void 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 | |
323 | static 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 | |
345 | void 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 | |
366 | void 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 | |
371 | void CoarrayChecker::Leave(const parser::CriticalStmt &x) { |
372 | CheckSyncStatList(context_, std::get<std::list<parser::StatOrErrmsg>>(x.t)); |
373 | } |
374 | |
375 | void 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 | |
385 | void 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 | |
397 | void 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 | |
409 | void 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. |
423 | void 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 | |
455 | void 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 | |