130 lines · 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-exception6//7//===----------------------------------------------------------------------===//8 9#include "check-select-rank.h"10#include "flang/Common/idioms.h"11#include "flang/Parser/message.h"12#include "flang/Parser/tools.h"13#include "flang/Semantics/tools.h"14#include "flang/Support/Fortran.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 checks32 const Symbol *saveSelSymbol{nullptr};33 if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {34 if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {35 if (!semantics::IsAssumedRank(*sel)) { // C115036 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 checks50 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 &) { // C115366 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 &) { // C115378 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 C116090 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 show98 // value repeat error, else stack smashing occurs99 if (*val < 0 || *val > common::maxRank) { // C1151100 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::semantics130