From 332e6aea37a2777c06eb7d0960edf33b5869b0de Mon Sep 17 00:00:00 2001 From: sameeran joshi Date: Wed, 22 Apr 2020 14:46:37 +0530 Subject: [PATCH] [flang]Semantics for SELECT RANK. Summary: Initially on github I worked on semantic checks.Then I tried some compile-time test of the rank value, they were failing as there were no symbols generated for them inside SELECT RANK's scope.So I went further to add new symbol in each scope, also added the respective 'rank: ' field for a symbol when we dump the symboltable. I added a field to keep track of the rank in AssocEntityDetails class.This caused shape analysis framework to become inconsistent. So shape analysis framework was updated to handle this new representation. * I added more tests for above changes. * On phabricator I addressed some minor changes. * Lastly I worked on review comments. Reviewers: klausler,sscalpone,DavidTruby,kiranchandramohan,tskeith,anchu-rajendran,kiranktp Reviewed By:klausler, DavidTruby, tskeith Subscribers:#flang-commits, #llvm-commits Tags: #flang, #llvm Differential Revision: https://reviews.llvm.org/D78623 --- flang/include/flang/Evaluate/shape.h | 8 +- flang/include/flang/Semantics/symbol.h | 14 +- flang/lib/Evaluate/shape.cpp | 23 +- flang/lib/Semantics/CMakeLists.txt | 1 + flang/lib/Semantics/check-select-rank.cpp | 129 +++++++++++ flang/lib/Semantics/check-select-rank.h | 26 +++ flang/lib/Semantics/resolve-names.cpp | 36 +++ flang/lib/Semantics/semantics.cpp | 3 +- flang/lib/Semantics/symbol.cpp | 4 + flang/test/Semantics/select-rank.f90 | 265 ++++++++++++++++++++++ flang/test/Semantics/select-rank02.f90 | 62 +++++ 11 files changed, 554 insertions(+), 17 deletions(-) create mode 100644 flang/lib/Semantics/check-select-rank.cpp create mode 100644 flang/lib/Semantics/check-select-rank.h create mode 100644 flang/test/Semantics/select-rank.f90 create mode 100644 flang/test/Semantics/select-rank02.f90 diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index 4c46d89e34066..053164ba7a9b1 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -128,7 +128,13 @@ class GetShapeHelper 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 { diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 9fba0f995f38c..2a95f483a173e 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -147,9 +147,12 @@ class AssocEntityDetails : public EntityDetails { 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. @@ -320,8 +323,8 @@ class FinalProcDetails {}; // TODO 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_; } @@ -587,7 +590,6 @@ class Symbol { } void SetType(const DeclTypeSpec &); - bool IsDummy() const; bool IsFuncResult() const; bool IsObjectArray() const; @@ -637,7 +639,11 @@ class Symbol { [](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; } diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 9cf684b699a11..c5b8a5e88ce72 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -399,13 +399,9 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { 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 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { } }, [&](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 @@ auto GetShapeHelper::operator()(const Component &component) const -> Result { 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); } diff --git a/flang/lib/Semantics/CMakeLists.txt b/flang/lib/Semantics/CMakeLists.txt index aaeeca1523b49..ff2eba6d12e0b 100644 --- a/flang/lib/Semantics/CMakeLists.txt +++ b/flang/lib/Semantics/CMakeLists.txt @@ -20,6 +20,7 @@ add_flang_library(FortranSemantics check-omp-structure.cpp check-purity.cpp check-return.cpp + check-select-rank.cpp check-stop.cpp compute-offsets.cpp expression.cpp diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp new file mode 100644 index 0000000000000..3487fb564df04 --- /dev/null +++ b/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 diff --git a/flang/lib/Semantics/check-select-rank.h b/flang/lib/Semantics/check-select-rank.h new file mode 100644 index 0000000000000..50c968fce8bd7 --- /dev/null +++ b/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_ diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 04acacb18fc1c..4bab50931ffb5 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -985,11 +985,16 @@ class ConstructVisitor : public virtual DeclarationVisitor { 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 &); @@ -5133,6 +5138,15 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) { } } +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; @@ -5141,6 +5155,14 @@ void ConstructVisitor::Post(const parser::SelectTypeConstruct::TypeCase &) { 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)) { @@ -5152,6 +5174,20 @@ void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) { } } +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; diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp index 276c8e37de80c..4eacb9972ebe7 100644 --- a/flang/lib/Semantics/semantics.cpp +++ b/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 "compute-offsets.h" #include "mod-file.h" @@ -156,7 +157,7 @@ using StatementSemanticsPass2 = SemanticsVisitor; + PurityChecker, ReturnStmtChecker, SelectRankConstructChecker, StopChecker>; static bool PerformStatementSemantics( SemanticsContext &context, parser::Program &program) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 97ed321f2a2a2..c22f8d08e55f6 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -119,6 +119,7 @@ void EntityDetails::set_type(const DeclTypeSpec &type) { 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 &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; } diff --git a/flang/test/Semantics/select-rank.f90 b/flang/test/Semantics/select-rank.f90 new file mode 100644 index 0000000000000..71fc9d85f185b --- /dev/null +++ b/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 diff --git a/flang/test/Semantics/select-rank02.f90 b/flang/test/Semantics/select-rank02.f90 new file mode 100644 index 0000000000000..00331f4b9822c --- /dev/null +++ b/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