[flang-commits] [flang] 332e6ae - [flang]Semantics for SELECT RANK.
Sameeran joshi via flang-commits
flang-commits at lists.llvm.org
Thu May 7 20:34:42 PDT 2020
Author: sameeran joshi
Date: 2020-05-08T08:52:31+05:30
New Revision: 332e6aea37a2777c06eb7d0960edf33b5869b0de
URL: https://github.com/llvm/llvm-project/commit/332e6aea37a2777c06eb7d0960edf33b5869b0de
DIFF: https://github.com/llvm/llvm-project/commit/332e6aea37a2777c06eb7d0960edf33b5869b0de.diff
LOG: [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
Added:
flang/lib/Semantics/check-select-rank.cpp
flang/lib/Semantics/check-select-rank.h
flang/test/Semantics/select-rank.f90
flang/test/Semantics/select-rank02.f90
Modified:
flang/include/flang/Evaluate/shape.h
flang/include/flang/Semantics/symbol.h
flang/lib/Evaluate/shape.cpp
flang/lib/Semantics/CMakeLists.txt
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/semantics.cpp
flang/lib/Semantics/symbol.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index 4c46d89e3406..053164ba7a9b 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 <typename T>
MaybeExtentExpr GetArrayConstructorValueExtent(
const ArrayConstructorValue<T> &value) const {
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 9fba0f995f38..2a95f483a173 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<int> rank() const { return rank_; }
private:
MaybeExpr expr_;
+ std::optional<int> 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 9cf684b699a1..c5b8a5e88ce7 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<semantics::ObjectEntityDetails>()) {
- 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<semantics::AssocEntityDetails>()) {
+ 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 aaeeca1523b4..ff2eba6d12e0 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 000000000000..3487fb564df0
--- /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 <list>
+#include <optional>
+#include <set>
+#include <tuple>
+#include <variant>
+
+namespace Fortran::semantics {
+
+void SelectRankConstructChecker::Leave(
+ const parser::SelectRankConstruct &selectRankConstruct) {
+ const auto &selectRankStmt{
+ std::get<parser::Statement<parser::SelectRankStmt>>(
+ selectRankConstruct.t)};
+ const auto &selectRankStmtSel{
+ std::get<parser::Selector>(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<std::list<parser::SelectRankConstruct::RankCase>>(
+ selectRankConstruct.t)};
+ bool defaultRankFound{false};
+ bool starRankFound{false};
+ parser::CharBlock prevLocDefault;
+ parser::CharBlock prevLocStar;
+ std::optional<parser::CharBlock> caseForRank[common::maxRank + 1];
+
+ for (const auto &rankCase : rankCaseList) {
+ const auto &rankCaseStmt{
+ std::get<parser::Statement<parser::SelectRankCaseStmt>>(rankCase.t)};
+ const auto &rank{
+ std::get<parser::SelectRankCaseStmt::Rank>(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 000000000000..50c968fce8bd
--- /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 04acacb18fc1..4bab50931ffb 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<parser::Name> &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<parser::Default>(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<parser::ScalarIntConstantExpr>(&x.u)}) {
+ MaybeIntExpr expr{EvaluateIntExpr(*init)};
+ if (auto val{evaluate::ToInt64(expr)}) {
+ auto &details{symbol->get<AssocEntityDetails>()};
+ 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 276c8e37de80..4eacb9972ebe 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<AllocateChecker,
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) {
diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index 97ed321f2a2a..c22f8d08e55f 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<const EntityDetails *>(&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 000000000000..71fc9d85f185
--- /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 000000000000..00331f4b9822
--- /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
More information about the flang-commits
mailing list