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
21namespace Fortran::semantics {
22
23void 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 common::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"_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"_en_US);
87 }
88 if (saveSelSymbol &&
89 IsAllocatableOrPointer(*saveSelSymbol)) { // F'2023 C1160
90 context_.Say(rankCaseStmt.source,
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"_en_US);
115 }
116 }
117 }
118 },
119 },
120 rank.u);
121 }
122}
123
124const SomeExpr *SelectRankConstructChecker::GetExprFromSelector(
125 const parser::Selector &selector) {
126 return common::visit([](const auto &x) { return GetExpr(x); }, selector.u);
127}
128
129} // namespace Fortran::semantics
130

source code of flang/lib/Semantics/check-select-rank.cpp