llvm-project

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
    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

124
const 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