flang/lib/Semantics/check-select-rank.cpp

   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)) { // 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"_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