Index: flang/include/flang/Evaluate/shape.h =================================================================== --- flang/include/flang/Evaluate/shape.h +++ flang/include/flang/Evaluate/shape.h @@ -128,7 +128,13 @@ private: static Result Scalar() { return Shape{}; } - + Shape CreateShape(int rank, NamedEntity &base) const { + Shape shape; + for (int dimension{0}; dimension < rank; ++dimension) { + shape.emplace_back(GetExtent(context_, base, dimension)); + } + return shape; + } template MaybeExtentExpr GetArrayConstructorValueExtent( const ArrayConstructorValue &value) const { Index: flang/include/flang/Semantics/symbol.h =================================================================== --- flang/include/flang/Semantics/symbol.h +++ flang/include/flang/Semantics/symbol.h @@ -145,9 +145,12 @@ AssocEntityDetails &operator=(const AssocEntityDetails &) = default; AssocEntityDetails &operator=(AssocEntityDetails &&) = default; const MaybeExpr &expr() const { return expr_; } + void set_rank(int rank); + std::optional rank() const { return rank_; } private: MaybeExpr expr_; + std::optional rank_; }; // An entity known to be an object. @@ -314,8 +317,8 @@ class MiscDetails { public: ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe, - ComplexPartIm, KindParamInquiry, LenParamInquiry, SelectTypeAssociateName, - TypeBoundDefinedOp); + ComplexPartIm, KindParamInquiry, LenParamInquiry, SelectRankAssociateName, + SelectTypeAssociateName, TypeBoundDefinedOp); MiscDetails(Kind kind) : kind_{kind} {} Kind kind() const { return kind_; } @@ -577,7 +580,6 @@ } void SetType(const DeclTypeSpec &); - bool IsDummy() const; bool IsFuncResult() const; bool IsObjectArray() const; @@ -627,7 +629,11 @@ [](const ObjectEntityDetails &oed) { return oed.shape().Rank(); }, [](const AssocEntityDetails &aed) { if (const auto &expr{aed.expr()}) { - return expr->Rank(); + if (auto assocRank{aed.rank()}) { + return *assocRank; + } else { + return expr->Rank(); + } } else { return 0; } Index: flang/lib/Evaluate/shape.cpp =================================================================== --- flang/lib/Evaluate/shape.cpp +++ flang/lib/Evaluate/shape.cpp @@ -399,13 +399,9 @@ if (IsImpliedShape(symbol)) { return (*this)(object.init()); } else { - Shape shape; int n{object.shape().Rank()}; NamedEntity base{symbol}; - for (int dimension{0}; dimension < n; ++dimension) { - shape.emplace_back(GetExtent(context_, base, dimension)); - } - return Result{shape}; + return Result{CreateShape(n, base)}; } }, [](const semantics::EntityDetails &) { @@ -419,7 +415,13 @@ } }, [&](const semantics::AssocEntityDetails &assoc) { - return (*this)(assoc.expr()); + if (!assoc.rank()) { + return (*this)(assoc.expr()); + } else { + int n{assoc.rank().value()}; + NamedEntity base{symbol}; + return Result{CreateShape(n, base)}; + } }, [&](const semantics::SubprogramDetails &subp) { if (subp.isFunction()) { @@ -448,12 +450,11 @@ if (rank == 0) { return (*this)(component.base()); } else if (symbol.has()) { - Shape shape; NamedEntity base{Component{component}}; - for (int dimension{0}; dimension < rank; ++dimension) { - shape.emplace_back(GetExtent(context_, base, dimension)); - } - return shape; + return CreateShape(rank, base); + } else if (symbol.has()) { + NamedEntity base{Component{component}}; + return Result{CreateShape(rank, base)}; } else { return (*this)(symbol); } Index: flang/lib/Semantics/CMakeLists.txt =================================================================== --- flang/lib/Semantics/CMakeLists.txt +++ flang/lib/Semantics/CMakeLists.txt @@ -20,6 +20,7 @@ check-omp-structure.cpp check-purity.cpp check-return.cpp + check-select-rank.cpp check-stop.cpp expression.cpp mod-file.cpp Index: flang/lib/Semantics/check-select-rank.h =================================================================== --- /dev/null +++ flang/lib/Semantics/check-select-rank.h @@ -0,0 +1,26 @@ +//===-- lib/Semantics/check-select-rank.h -----------------------*- C++ -*-===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#ifndef FORTRAN_SEMANTICS_CHECK_SELECT_STMT_H_ +#define FORTRAN_SEMANTICS_CHECK_SELECT_STMT_H_ + +#include "flang/Parser/parse-tree.h" +#include "flang/Semantics/semantics.h" + +namespace Fortran::semantics { +class SelectRankConstructChecker : public virtual BaseChecker { +public: + SelectRankConstructChecker(SemanticsContext &context) : context_{context} {} + void Leave(const parser::SelectRankConstruct &); + +private: + const SomeExpr *GetExprFromSelector(const parser::Selector &); + SemanticsContext &context_; +}; +} // namespace Fortran::semantics +#endif // FORTRAN_SEMANTICS_CHECK_SELECT_STMT_H_ Index: flang/lib/Semantics/check-select-rank.cpp =================================================================== --- /dev/null +++ flang/lib/Semantics/check-select-rank.cpp @@ -0,0 +1,129 @@ +//===-- lib/Semantics/check-select-rank.cpp -------------------------------===// +// +// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. +// See https://llvm.org/LICENSE.txt for license information. +// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +// +//===----------------------------------------------------------------------===// + +#include "check-select-rank.h" +#include "flang/Common/Fortran.h" +#include "flang/Common/idioms.h" +#include "flang/Parser/message.h" +#include "flang/Parser/tools.h" +#include "flang/Semantics/tools.h" +#include +#include +#include +#include +#include + +namespace Fortran::semantics { + +void SelectRankConstructChecker::Leave( + const parser::SelectRankConstruct &selectRankConstruct) { + const auto &selectRankStmt{ + std::get>( + selectRankConstruct.t)}; + const auto &selectRankStmtSel{ + std::get(selectRankStmt.statement.t)}; + + // R1149 select-rank-stmt checks + const Symbol *saveSelSymbol{nullptr}; + if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) { + if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) { + if (!IsAssumedRankArray(*sel)) { // C1150 + context_.Say(parser::FindSourceLocation(selectRankStmtSel), + "Selector '%s' is not an assumed-rank array variable"_err_en_US, + sel->name().ToString()); + } else { + saveSelSymbol = sel; + } + } else { + context_.Say(parser::FindSourceLocation(selectRankStmtSel), + "Selector '%s' is not an assumed-rank array variable"_err_en_US, + parser::FindSourceLocation(selectRankStmtSel).ToString()); + } + } + + // R1150 select-rank-case-stmt checks + auto &rankCaseList{std::get>( + selectRankConstruct.t)}; + bool defaultRankFound{false}; + bool starRankFound{false}; + parser::CharBlock prevLocDefault; + parser::CharBlock prevLocStar; + std::optional caseForRank[common::maxRank + 1]; + + for (const auto &rankCase : rankCaseList) { + const auto &rankCaseStmt{ + std::get>(rankCase.t)}; + const auto &rank{ + std::get(rankCaseStmt.statement.t)}; + std::visit( + common::visitors{ + [&](const parser::Default &) { // C1153 + if (!defaultRankFound) { + defaultRankFound = true; + prevLocDefault = rankCaseStmt.source; + } else { + context_ + .Say(rankCaseStmt.source, + "Not more than one of the selectors of SELECT RANK " + "statement may be DEFAULT"_err_en_US) + .Attach(prevLocDefault, "Previous use"_err_en_US); + } + }, + [&](const parser::Star &) { // C1153 + if (!starRankFound) { + starRankFound = true; + prevLocStar = rankCaseStmt.source; + } else { + context_ + .Say(rankCaseStmt.source, + "Not more than one of the selectors of SELECT RANK " + "statement may be '*'"_err_en_US) + .Attach(prevLocStar, "Previous use"_err_en_US); + } + if (saveSelSymbol && + IsAllocatableOrPointer(*saveSelSymbol)) { // C1155 + context_.Say(parser::FindSourceLocation(selectRankStmtSel), + "RANK (*) cannot be used when selector is " + "POINTER or ALLOCATABLE"_err_en_US); + } + }, + [&](const parser::ScalarIntConstantExpr &init) { + if (auto val{GetIntValue(init)}) { + // If value is in valid range, then only show + // value repeat error, else stack smashing occurs + if (*val < 0 || *val > common::maxRank) { // C1151 + context_.Say(rankCaseStmt.source, + "The value of the selector must be " + "between zero and %d"_err_en_US, + common::maxRank); + + } else { + if (!caseForRank[*val].has_value()) { + caseForRank[*val] = rankCaseStmt.source; + } else { + auto prevloc{caseForRank[*val].value()}; + context_ + .Say(rankCaseStmt.source, + "Same rank value (%d) not allowed more than once"_err_en_US, + *val) + .Attach(prevloc, "Previous use"_err_en_US); + } + } + } + }, + }, + rank.u); + } +} + +const SomeExpr *SelectRankConstructChecker::GetExprFromSelector( + const parser::Selector &selector) { + return std::visit([](const auto &x) { return GetExpr(x); }, selector.u); +} + +} // namespace Fortran::semantics Index: flang/lib/Semantics/resolve-names.cpp =================================================================== --- flang/lib/Semantics/resolve-names.cpp +++ flang/lib/Semantics/resolve-names.cpp @@ -985,11 +985,16 @@ void Post(const parser::EndAssociateStmt &); void Post(const parser::Association &); void Post(const parser::SelectTypeStmt &); + void Post(const parser::SelectRankStmt &); bool Pre(const parser::SelectTypeConstruct &); void Post(const parser::SelectTypeConstruct &); bool Pre(const parser::SelectTypeConstruct::TypeCase &); void Post(const parser::SelectTypeConstruct::TypeCase &); + // Creates Block scopes with neither symbol name nor symbol details. + bool Pre(const parser::SelectRankConstruct::RankCase &); + void Post(const parser::SelectRankConstruct::RankCase &); void Post(const parser::TypeGuardStmt::Guard &); + void Post(const parser::SelectRankCaseStmt::Rank &); bool Pre(const parser::ChangeTeamStmt &); void Post(const parser::EndChangeTeamStmt &); void Post(const parser::CoarrayAssociation &); @@ -5098,6 +5103,15 @@ } } +void ConstructVisitor::Post(const parser::SelectRankStmt &x) { + auto &association{GetCurrentAssociation()}; + if (const std::optional &name{std::get<1>(x.t)}) { + // This isn't a name in the current scope, it is in each SelectRankCaseStmt + MakePlaceholder(*name, MiscDetails::Kind::SelectRankAssociateName); + association.name = &*name; + } +} + bool ConstructVisitor::Pre(const parser::SelectTypeConstruct::TypeCase &) { PushScope(Scope::Kind::Block, nullptr); return true; @@ -5106,6 +5120,14 @@ PopScope(); } +bool ConstructVisitor::Pre(const parser::SelectRankConstruct::RankCase &) { + PushScope(Scope::Kind::Block, nullptr); + return true; +} +void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) { + PopScope(); +} + void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { if (auto *symbol{MakeAssocEntity()}) { if (std::holds_alternative(x.u)) { @@ -5117,6 +5139,20 @@ } } +void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) { + if (auto *symbol{MakeAssocEntity()}) { + SetTypeFromAssociation(*symbol); + SetAttrsFromAssociation(*symbol); + if (const auto *init{std::get_if(&x.u)}) { + MaybeIntExpr expr{EvaluateIntExpr(*init)}; + if (auto val{evaluate::ToInt64(expr)}) { + auto &details{symbol->get()}; + details.set_rank(*val); + } + } + } +} + bool ConstructVisitor::Pre(const parser::SelectRankConstruct &) { PushAssociation(); return true; Index: flang/lib/Semantics/semantics.cpp =================================================================== --- flang/lib/Semantics/semantics.cpp +++ flang/lib/Semantics/semantics.cpp @@ -25,6 +25,7 @@ #include "check-omp-structure.h" #include "check-purity.h" #include "check-return.h" +#include "check-select-rank.h" #include "check-stop.h" #include "mod-file.h" #include "resolve-labels.h" @@ -155,7 +156,7 @@ ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker, DataChecker, DeallocateChecker, DoForallChecker, IfStmtChecker, IoChecker, MiscChecker, NamelistChecker, NullifyChecker, OmpStructureChecker, - PurityChecker, ReturnStmtChecker, StopChecker>; + PurityChecker, ReturnStmtChecker, SelectRankConstructChecker, StopChecker>; static bool PerformStatementSemantics( SemanticsContext &context, parser::Program &program) { Index: flang/lib/Semantics/symbol.cpp =================================================================== --- flang/lib/Semantics/symbol.cpp +++ flang/lib/Semantics/symbol.cpp @@ -119,6 +119,7 @@ type_ = &type; } +void AssocEntityDetails::set_rank(int rank) { rank_ = rank; } void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; } void ObjectEntityDetails::set_shape(const ArraySpec &shape) { @@ -353,6 +354,9 @@ llvm::raw_ostream &operator<<( llvm::raw_ostream &os, const AssocEntityDetails &x) { os << *static_cast(&x); + if (auto assocRank{x.rank()}) { + os << " rank: " << *assocRank; + } DumpExpr(os, "expr", x.expr()); return os; } Index: flang/test/Semantics/select-rank.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/select-rank.f90 @@ -0,0 +1,265 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +!Tests for SELECT RANK Construct(R1148) +program select_rank + implicit none + integer, dimension(10:30, 10:20, -1:20) :: x + integer, parameter :: y(*) = [1,2,3,4] + integer, dimension(5) :: z + integer, allocatable :: a(:) + + allocate(a(10:20)) + + call CALL_SHAPE(x) + call CALL_SHAPE(y) + call CALL_SHAPE(z) + call CALL_SHAPE(a) + +contains + !No error expected + subroutine CALL_ME(x) + implicit none + integer :: x(..) + SELECT RANK(x) + RANK (0) + print *, "PRINT RANK 0" + RANK (1) + print *, "PRINT RANK 1" + END SELECT + end + + subroutine CALL_ME9(x) + implicit none + integer :: x(..),j + boo: SELECT RANK(x) + RANK (1+0) + print *, "PRINT RANK 1" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == (1+0))) + END SELECT boo + end subroutine + + !Error expected + subroutine CALL_ME2(x) + implicit none + integer :: x(..) + integer :: y(3),j + !ERROR: Selector 'y' is not an assumed-rank array variable + SELECT RANK(y) + RANK (0) + print *, "PRINT RANK 0" + RANK (1) + print *, "PRINT RANK 1" + END SELECT + + SELECT RANK(x) + RANK(0) + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) ! will fail when RANK(x) is not zero here + END SELECT + end subroutine + + subroutine CALL_ME3(x) + implicit none + integer :: x(..),j + SELECT RANK(x) + !ERROR: The value of the selector must be between zero and 15 + RANK (16) + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 16)) + END SELECT + end subroutine + + subroutine CALL_ME4(x) + implicit none + integer :: x(..) + SELECT RANK(x) + RANK DEFAULT + print *, "ok " + !ERROR: Not more than one of the selectors of SELECT RANK statement may be DEFAULT + RANK DEFAULT + print *, "not ok" + RANK (3) + print *, "IT'S 3" + END SELECT + end subroutine + + subroutine CALL_ME5(x) + implicit none + integer :: x(..),j + SELECT RANK(x) + RANK (0) + print *, "PRINT RANK 0" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) + RANK(1) + print *, "PRINT RANK 1" + !ERROR: Same rank value (0) not allowed more than once + RANK(0) + print *, "ERROR" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) + RANK(1+1) + !ERROR: Same rank value (2) not allowed more than once + RANK(1+1) + END SELECT + end subroutine + + subroutine CALL_ME6(x) + implicit none + integer :: x(..),j + SELECT RANK(x) + RANK (3) + print *, "one" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3)) + !ERROR: The value of the selector must be between zero and 15 + RANK(-1) + print *, "rank: -ve" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == -1)) + END SELECT + end subroutine + + subroutine CALL_ME7(arg) + implicit none + integer :: i,j + integer, dimension(..), pointer :: arg + integer, pointer :: arg2 + !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE + select RANK(arg) + RANK (*) + print *, arg(1:1) + RANK (1) + print *, arg + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(arg) == 1)) + end select + + !ERROR: Selector 'arg2' is not an assumed-rank array variable + select RANK(arg2) + RANK (*) + print *,"This would lead to crash when saveSelSymbol has std::nullptr" + RANK (1) + print *, "Rank is 1" + end select + + end subroutine + + subroutine CALL_ME8(x) + implicit none + integer :: x(..),j + SELECT RANK(x) + Rank(2) + print *, "Now it's rank 2 " + RANK (*) + print *, "Going for a other rank" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) + !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*' + RANK (*) + print *, "This is Wrong" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) + END SELECT + end subroutine + + subroutine CALL_ME10(x) + implicit none + integer:: x(..), a=10,b=20,j + integer, dimension(10) :: arr = (/1,2,3,4,5/),brr + integer :: const_variable=10 + integer, pointer :: ptr,nullptr=>NULL() + type derived + character(len = 50) :: title + end type derived + type(derived) :: obj1 + + SELECT RANK(x) + Rank(2) + print *, "Now it's rank 2 " + RANK (*) + print *, "Going for a other rank" + !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*' + RANK (*) + print *, "This is Wrong" + END SELECT + + !ERROR: Selector 'brr' is not an assumed-rank array variable + SELECT RANK(ptr=>brr) + !ERROR: Must be a constant value + RANK(const_variable) + print *, "PRINT RANK 3" + !j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) + !ERROR: Must be a constant value + RANK(nullptr) + print *, "PRINT RANK 3" + END SELECT + + !ERROR: Selector 'x(1) + x(2)' is not an assumed-rank array variable + SELECT RANK (x(1) + x(2)) + + END SELECT + + !ERROR: Selector 'x(1)' is not an assumed-rank array variable + SELECT RANK(x(1)) + + END SELECT + + !ERROR: Selector 'x(1:2)' is not an assumed-rank array variable + SELECT RANK(x(1:2)) + + END SELECT + + !ERROR: 'x' is not an object of derived type + SELECT RANK(x(1)%x(2)) + + END SELECT + + !ERROR: Selector 'obj1%title' is not an assumed-rank array variable + SELECT RANK(obj1%title) + + END SELECT + + !ERROR: Selector 'arr(1:3)+ arr(4:5)' is not an assumed-rank array variable + SELECT RANK(arr(1:3)+ arr(4:5)) + + END SELECT + + SELECT RANK(ptr=>x) + RANK (3) + PRINT *, "PRINT RANK 3" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 0)) + RANK (1) + PRINT *, "PRINT RANK 1" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) + END SELECT + end subroutine + subroutine CALL_ME_TYPES(x) + implicit none + integer :: x(..),j + SELECT RANK(x) + !ERROR: Must have INTEGER type, but is LOGICAL(4) + RANK(.TRUE.) + !ERROR: Must have INTEGER type, but is REAL(4) + RANK(1.0) + !ERROR: Must be a constant value + RANK(RANK(x)) + !ERROR: Must have INTEGER type, but is CHARACTER(1) + RANK("STRING") + END SELECT + end subroutine + subroutine CALL_SHAPE(x) + implicit none + integer :: x(..) + integer :: j + integer, pointer :: ptr + SELECT RANK(x) + RANK(1) + print *, "RANK 1" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) + RANK (3) + print *, "RANK 3" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3)) + END SELECT + SELECT RANK(ptr => x ) + RANK(1) + print *, "RANK 1" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) + RANK (3) + print *, "RANK 3" + j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 3)) + END SELECT + + end subroutine + +end program Index: flang/test/Semantics/select-rank02.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/select-rank02.f90 @@ -0,0 +1,62 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +!Shape analysis related tests for SELECT RANK Construct(R1148) +program select_rank + implicit none + integer, dimension(2,3):: arr_pass + call check(arr_pass) + +contains + subroutine check(arr) + implicit none + integer :: arr(..) + INTEGER :: j + select rank (arr) + rank(2) + j = INT(0, KIND=MERGE(KIND(0), -1, SIZE(SHAPE(arr)) == 2)) !arr is dummy + end select + end subroutine + subroutine check2(arr) + implicit none + integer :: arr(..) + INTEGER :: j + integer,dimension(-1:10, 20:30) :: brr + + select rank (arr) + rank(2) + j = INT(0, KIND=MERGE(KIND(0), -1, SIZE(SHAPE(brr)) == 2)) !brr is local to subroutine + end select + end subroutine + subroutine checK3(arr) + implicit none + integer :: arr(..) + INTEGER :: j,I,n=5,m=5 + integer,dimension(-1:10, 20:30) :: brr + integer :: array(2) = [10,20] + REAL, DIMENSION(5, 5) :: A + select rank (arr) + rank(2) + FORALL (i=1:n,j=1:m,RANK(arr).EQ.SIZE(SHAPE(brr))) & + A(i,j) = 1/A(i,j) + end select + end subroutine + subroutine check4(arr) + implicit none + integer :: arr(..) + REAL, DIMENSION(2,3) :: A + REAL, DIMENSION(0:1,0:2) :: B + INTEGER :: j + select rank (arr) + rank(2) + A = B !will assign to only same shape after analysing in any order. + end select + end subroutine + subroutine check5(arr) + implicit none + integer :: arr(..) + INTEGER :: j + select rank (arr) + rank(2) + j = LOC(arr(1,2)) + end select + end subroutine +end program