1 //===-- lib/Semantics/check-select-rank.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-select-rank.h"
10 #include "flang/Common/Fortran.h"
11 #include "flang/Common/idioms.h"
12 #include "flang/Parser/message.h"
13 #include "flang/Parser/tools.h"
14 #include "flang/Semantics/tools.h"
15 #include <list>
16 #include <optional>
17 #include <set>
18 #include <tuple>
19 #include <variant>
20 
21 namespace Fortran::semantics {
22 
23 void SelectRankConstructChecker::Leave(
24     const parser::SelectRankConstruct &selectRankConstruct) {
25   const auto &selectRankStmt{
26       std::get<parser::Statement<parser::SelectRankStmt>>(
27           selectRankConstruct.t)};
28   const auto &selectRankStmtSel{
29       std::get<parser::Selector>(selectRankStmt.statement.t)};
30 
31   // R1149 select-rank-stmt checks
32   const Symbol *saveSelSymbol{nullptr};
33   if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {
34     if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {
35       if (!evaluate::IsAssumedRank(*sel)) { // C1150
36         context_.Say(parser::FindSourceLocation(selectRankStmtSel),
37             "Selector '%s' is not an assumed-rank array variable"_err_en_US,
38             sel->name().ToString());
39       } else {
40         saveSelSymbol = sel;
41       }
42     } else {
43       context_.Say(parser::FindSourceLocation(selectRankStmtSel),
44           "Selector '%s' is not an assumed-rank array variable"_err_en_US,
45           parser::FindSourceLocation(selectRankStmtSel).ToString());
46     }
47   }
48 
49   // R1150 select-rank-case-stmt checks
50   auto &rankCaseList{std::get<std::list<parser::SelectRankConstruct::RankCase>>(
51       selectRankConstruct.t)};
52   bool defaultRankFound{false};
53   bool starRankFound{false};
54   parser::CharBlock prevLocDefault;
55   parser::CharBlock prevLocStar;
56   std::optional<parser::CharBlock> caseForRank[common::maxRank + 1];
57 
58   for (const auto &rankCase : rankCaseList) {
59     const auto &rankCaseStmt{
60         std::get<parser::Statement<parser::SelectRankCaseStmt>>(rankCase.t)};
61     const auto &rank{
62         std::get<parser::SelectRankCaseStmt::Rank>(rankCaseStmt.statement.t)};
63     std::visit(
64         common::visitors{
65             [&](const parser::Default &) { // C1153
66               if (!defaultRankFound) {
67                 defaultRankFound = true;
68                 prevLocDefault = rankCaseStmt.source;
69               } else {
70                 context_
71                     .Say(rankCaseStmt.source,
72                         "Not more than one of the selectors of SELECT RANK "
73                         "statement may be DEFAULT"_err_en_US)
74                     .Attach(prevLocDefault, "Previous use"_err_en_US);
75               }
76             },
77             [&](const parser::Star &) { // C1153
78               if (!starRankFound) {
79                 starRankFound = true;
80                 prevLocStar = rankCaseStmt.source;
81               } else {
82                 context_
83                     .Say(rankCaseStmt.source,
84                         "Not more than one of the selectors of SELECT RANK "
85                         "statement may be '*'"_err_en_US)
86                     .Attach(prevLocStar, "Previous use"_err_en_US);
87               }
88               if (saveSelSymbol &&
89                   IsAllocatableOrPointer(*saveSelSymbol)) { // C1155
90                 context_.Say(parser::FindSourceLocation(selectRankStmtSel),
91                     "RANK (*) cannot be used when selector is "
92                     "POINTER or ALLOCATABLE"_err_en_US);
93               }
94             },
95             [&](const parser::ScalarIntConstantExpr &init) {
96               if (auto val{GetIntValue(init)}) {
97                 // If value is in valid range, then only show
98                 // value repeat error, else stack smashing occurs
99                 if (*val < 0 || *val > common::maxRank) { // C1151
100                   context_.Say(rankCaseStmt.source,
101                       "The value of the selector must be "
102                       "between zero and %d"_err_en_US,
103                       common::maxRank);
104 
105                 } else {
106                   if (!caseForRank[*val].has_value()) {
107                     caseForRank[*val] = rankCaseStmt.source;
108                   } else {
109                     auto prevloc{caseForRank[*val].value()};
110                     context_
111                         .Say(rankCaseStmt.source,
112                             "Same rank value (%d) not allowed more than once"_err_en_US,
113                             *val)
114                         .Attach(prevloc, "Previous use"_err_en_US);
115                   }
116                 }
117               }
118             },
119         },
120         rank.u);
121   }
122 }
123 
124 const SomeExpr *SelectRankConstructChecker::GetExprFromSelector(
125     const parser::Selector &selector) {
126   return std::visit([](const auto &x) { return GetExpr(x); }, selector.u);
127 }
128 
129 } // namespace Fortran::semantics
130