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:
CriticalBodyEnforce(SemanticsContext & context,parser::CharBlock criticalSourcePosition)22   CriticalBodyEnforce(
23       SemanticsContext &context, parser::CharBlock criticalSourcePosition)
24       : context_{context}, criticalSourcePosition_{criticalSourcePosition} {}
labels()25   std::set<parser::Label> labels() { return labels_; }
Pre(const T &)26   template <typename T> bool Pre(const T &) { return true; }
Post(const T &)27   template <typename T> void Post(const T &) {}
28 
Pre(const parser::Statement<T> & statement)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
Post(const parser::ReturnStmt &)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   }
Post(const parser::ExecutableConstruct & construct)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:
GetEnclosingMsg()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>
CheckTeamType(SemanticsContext & context,const T & x)66 static void CheckTeamType(SemanticsContext &context, const T &x) {
67   if (const auto *expr{GetExpr(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 
CheckTeamStat(SemanticsContext & context,const parser::ImageSelectorSpec::Stat & stat)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 
Leave(const parser::ChangeTeamStmt & x)85 void CoarrayChecker::Leave(const parser::ChangeTeamStmt &x) {
86   CheckNamesAreDistinct(std::get<std::list<parser::CoarrayAssociation>>(x.t));
87   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
88 }
89 
Leave(const parser::SyncTeamStmt & x)90 void CoarrayChecker::Leave(const parser::SyncTeamStmt &x) {
91   CheckTeamType(context_, std::get<parser::TeamValue>(x.t));
92 }
93 
Leave(const parser::ImageSelector & imageSelector)94 void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
95   haveStat_ = false;
96   haveTeam_ = false;
97   haveTeamNumber_ = false;
98   for (const auto &imageSelectorSpec :
99       std::get<std::list<parser::ImageSelectorSpec>>(imageSelector.t)) {
100     if (const auto *team{
101             std::get_if<parser::TeamValue>(&imageSelectorSpec.u)}) {
102       if (haveTeam_) {
103         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
104             "TEAM value can only be specified once"_err_en_US);
105       }
106       CheckTeamType(context_, *team);
107       haveTeam_ = true;
108     }
109     if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
110             &imageSelectorSpec.u)}) {
111       if (haveStat_) {
112         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
113             "STAT variable can only be specified once"_err_en_US);
114       }
115       CheckTeamStat(context_, *stat);
116       haveStat_ = true;
117     }
118     if (std::get_if<parser::ImageSelectorSpec::Team_Number>(
119             &imageSelectorSpec.u)) {
120       if (haveTeamNumber_) {
121         context_.Say(parser::FindSourceLocation(imageSelectorSpec), // C929
122             "TEAM_NUMBER value can only be specified once"_err_en_US);
123       }
124       haveTeamNumber_ = true;
125     }
126   }
127   if (haveTeam_ && haveTeamNumber_) {
128     context_.Say(parser::FindSourceLocation(imageSelector), // C930
129         "Cannot specify both TEAM and TEAM_NUMBER"_err_en_US);
130   }
131 }
132 
Leave(const parser::FormTeamStmt & x)133 void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
134   CheckTeamType(context_, std::get<parser::TeamVariable>(x.t));
135 }
136 
Enter(const parser::CriticalConstruct & x)137 void CoarrayChecker::Enter(const parser::CriticalConstruct &x) {
138   auto &criticalStmt{std::get<parser::Statement<parser::CriticalStmt>>(x.t)};
139 
140   const parser::Block &block{std::get<parser::Block>(x.t)};
141   CriticalBodyEnforce criticalBodyEnforce{context_, criticalStmt.source};
142   parser::Walk(block, criticalBodyEnforce);
143 
144   // C1119
145   LabelEnforce criticalLabelEnforce{
146       context_, criticalBodyEnforce.labels(), criticalStmt.source, "CRITICAL"};
147   parser::Walk(block, criticalLabelEnforce);
148 }
149 
150 // Check that coarray names and selector names are all distinct.
CheckNamesAreDistinct(const std::list<parser::CoarrayAssociation> & list)151 void CoarrayChecker::CheckNamesAreDistinct(
152     const std::list<parser::CoarrayAssociation> &list) {
153   std::set<parser::CharBlock> names;
154   auto getPreviousUse{
155       [&](const parser::Name &name) -> const parser::CharBlock * {
156         auto pair{names.insert(name.source)};
157         return !pair.second ? &*pair.first : nullptr;
158       }};
159   for (const auto &assoc : list) {
160     const auto &decl{std::get<parser::CodimensionDecl>(assoc.t)};
161     const auto &selector{std::get<parser::Selector>(assoc.t)};
162     const auto &declName{std::get<parser::Name>(decl.t)};
163     if (context_.HasError(declName)) {
164       continue; // already reported an error about this name
165     }
166     if (auto *prev{getPreviousUse(declName)}) {
167       Say2(declName.source, // C1113
168           "Coarray '%s' was already used as a selector or coarray in this statement"_err_en_US,
169           *prev, "Previous use of '%s'"_en_US);
170     }
171     // ResolveNames verified the selector is a simple name
172     const parser::Name *name{parser::Unwrap<parser::Name>(selector)};
173     if (name) {
174       if (auto *prev{getPreviousUse(*name)}) {
175         Say2(name->source, // C1113, C1115
176             "Selector '%s' was already used as a selector or coarray in this statement"_err_en_US,
177             *prev, "Previous use of '%s'"_en_US);
178       }
179     }
180   }
181 }
182 
Say2(const parser::CharBlock & name1,parser::MessageFixedText && msg1,const parser::CharBlock & name2,parser::MessageFixedText && msg2)183 void CoarrayChecker::Say2(const parser::CharBlock &name1,
184     parser::MessageFixedText &&msg1, const parser::CharBlock &name2,
185     parser::MessageFixedText &&msg2) {
186   context_.Say(name1, std::move(msg1), name1)
187       .Attach(name2, std::move(msg2), name2);
188 }
189 } // namespace Fortran::semantics
190