[flang-commits] [flang] 9ab292d - [flang] Add/fix some semantic checks for assumed-rank (#96194)
via flang-commits
flang-commits at lists.llvm.org
Mon Jun 24 09:57:34 PDT 2024
Author: Peter Klausler
Date: 2024-06-24T09:57:30-07:00
New Revision: 9ab292d72651c6dda098a653320f7fbb3624b778
URL: https://github.com/llvm/llvm-project/commit/9ab292d72651c6dda098a653320f7fbb3624b778
DIFF: https://github.com/llvm/llvm-project/commit/9ab292d72651c6dda098a653320f7fbb3624b778.diff
LOG: [flang] Add/fix some semantic checks for assumed-rank (#96194)
Catch some cases where assumed rank dummy arguments are not allowed.
Added:
Modified:
flang/include/flang/Evaluate/tools.h
flang/lib/Semantics/check-allocate.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/test/Semantics/select-rank03.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 340325b59c0ab..625f9e5f6576f 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -98,6 +98,9 @@ template <typename T> bool IsAssumedRank(const Expr<T> &expr) {
template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
return x && IsAssumedRank(*x);
}
+template <typename A> bool IsAssumedRank(const A *x) {
+ return x && IsAssumedRank(*x);
+}
// Predicate: true when an expression is a coarray (corank > 0)
bool IsCoarray(const ActualArgument &);
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index b4c5660670579..a4fa72b03ca18 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -539,7 +539,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
// Shape related checks
if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
context.Say(name_.source,
- "An assumed-rank object may not appear in an ALLOCATE statement"_err_en_US);
+ "An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
return false;
}
if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 4ebd5bedaf018..8fe90eedc913f 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,11 +67,9 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
messages.Say(
"Coarray argument requires an explicit interface"_err_en_US);
}
- if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (details->IsAssumedRank()) {
- messages.Say(
- "Assumed rank argument requires an explicit interface"_err_en_US);
- }
+ if (evaluate::IsAssumedRank(symbol)) {
+ messages.Say(
+ "Assumed rank argument requires an explicit interface"_err_en_US);
}
if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
messages.Say(
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 60787ccf4f5af..dae4050279200 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -252,8 +252,7 @@ void CheckHelper::Check(const Symbol &symbol) {
&symbol == &symbol.GetUltimate()) {
if (context_.ShouldWarn(common::LanguageFeature::LongNames)) {
WarnIfNotInModuleFile(symbol.name(),
- "%s has length %d, which is greater than the maximum name length "
- "%d"_port_en_US,
+ "%s has length %d, which is greater than the maximum name length %d"_port_en_US,
symbol.name(), symbol.name().size(), common::maxNameLen);
}
}
@@ -466,11 +465,16 @@ void CheckHelper::Check(const Symbol &symbol) {
symbol.name());
}
}
- if (IsProcedure(symbol) && !symbol.HasExplicitInterface() &&
- symbol.Rank() > 0) {
- messages_.Say(
- "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
- symbol.name());
+ if (IsProcedure(symbol)) {
+ if (IsAllocatable(symbol)) {
+ messages_.Say(
+ "Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
+ }
+ if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
+ messages_.Say(
+ "Procedure '%s' may not be an array without an explicit interface"_err_en_US,
+ symbol.name());
+ }
}
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 803c655b3174f..d80b3b65f0a98 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -153,6 +153,7 @@ class ArgumentAnalyzer {
bool CheckConformance();
bool CheckAssignmentConformance();
bool CheckForNullPointer(const char *where = "as an operand here");
+ bool CheckForAssumedRank(const char *where = "as an operand here");
// Find and return a user-defined operator or report an error.
// The provided message is used if there is no such operator.
@@ -3200,6 +3201,7 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
if (!procRef) {
analyzer.CheckForNullPointer(
"in a non-pointer intrinsic assignment statement");
+ analyzer.CheckForAssumedRank("in an assignment statement");
const Expr<SomeType> &lhs{analyzer.GetExpr(0)};
if (auto dyType{lhs.GetType()};
dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
@@ -3394,6 +3396,7 @@ static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
if (!analyzer.fatalErrors()) {
if (analyzer.IsIntrinsicNumeric(opr)) {
analyzer.CheckForNullPointer();
+ analyzer.CheckForAssumedRank();
if (opr == NumericOperator::Add) {
return analyzer.MoveExpr(0);
} else {
@@ -3428,6 +3431,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
if (!analyzer.fatalErrors()) {
if (analyzer.IsIntrinsicLogical()) {
analyzer.CheckForNullPointer();
+ analyzer.CheckForAssumedRank();
return AsGenericExpr(
LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
} else {
@@ -3476,6 +3480,7 @@ MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
if (!analyzer.fatalErrors()) {
if (analyzer.IsIntrinsicNumeric(opr)) {
analyzer.CheckForNullPointer();
+ analyzer.CheckForAssumedRank();
analyzer.CheckConformance();
return NumericOperation<OPR>(context.GetContextualMessages(),
analyzer.MoveExpr(0), analyzer.MoveExpr(1),
@@ -3525,6 +3530,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
if (!analyzer.fatalErrors()) {
if (analyzer.IsIntrinsicConcat()) {
analyzer.CheckForNullPointer();
+ analyzer.CheckForAssumedRank();
return common::visit(
[&](auto &&x, auto &&y) -> MaybeExpr {
using T = ResultType<decltype(x)>;
@@ -3572,6 +3578,7 @@ MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
if (leftType && rightType &&
analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {
analyzer.CheckForNullPointer("as a relational operand");
+ analyzer.CheckForAssumedRank("as a relational operand");
return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
} else {
@@ -3617,6 +3624,7 @@ MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
if (!analyzer.fatalErrors()) {
if (analyzer.IsIntrinsicLogical()) {
analyzer.CheckForNullPointer("as a logical operand");
+ analyzer.CheckForAssumedRank("as a logical operand");
return AsGenericExpr(BinaryLogicalOperation(opr,
std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
@@ -4330,6 +4338,18 @@ bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
return true;
}
+bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
+ for (const std::optional<ActualArgument> &arg : actuals_) {
+ if (arg && IsAssumedRank(arg->UnwrapExpr())) {
+ context_.Say(source_,
+ "An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
+ fatalErrors_ = true;
+ return false;
+ }
+ }
+ return true;
+}
+
MaybeExpr ArgumentAnalyzer::TryDefinedOp(
const char *opr, parser::MessageFixedText error, bool isUserOp) {
if (AnyUntypedOrMissingOperand()) {
@@ -4404,7 +4424,7 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(
context_.Say(
"Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
- } else if (CheckForNullPointer()) {
+ } else if (CheckForNullPointer() && CheckForAssumedRank()) {
context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
}
return result;
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index a5c389766e174..6c634c6413191 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -148,6 +148,9 @@ bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
msg->Attach(std::move(*whyNot));
}
return false;
+ } else if (evaluate::IsAssumedRank(lhs)) {
+ Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US);
+ return false;
} else {
return true;
}
diff --git a/flang/test/Semantics/select-rank03.f90 b/flang/test/Semantics/select-rank03.f90
index 8a965e950d385..77b76f5f584ca 100644
--- a/flang/test/Semantics/select-rank03.f90
+++ b/flang/test/Semantics/select-rank03.f90
@@ -52,10 +52,12 @@ subroutine allocatables(a)
!ERROR: Whole assumed-size array 'a' may not appear here without subscripts
a = 1.
rank default
- !ERROR: An assumed-rank object may not appear in an ALLOCATE statement
+ !ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
allocate(a)
deallocate(a)
- a = 1.
+ !ERROR: An assumed-rank dummy argument is not allowed in an assignment statement
+ !ERROR: An assumed-rank dummy argument is not allowed as an operand here
+ a = a + 1.
end select
! Test nested associations
select rank(a)
@@ -121,11 +123,13 @@ subroutine pointers(p)
!ERROR: Whole assumed-size array 'p' may not appear here without subscripts
deallocate(p)
rank default
- !ERROR: An assumed-rank object may not appear in an ALLOCATE statement
+ !ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
allocate(p)
deallocate(p)
+ !ERROR: The left-hand side of a pointer assignment must not be an assumed-rank dummy argument
!ERROR: pointer 'p' associated with object 't0' with incompatible type or shape
p => t0
+ !ERROR: The left-hand side of a pointer assignment must not be an assumed-rank dummy argument
!ERROR: pointer 'p' associated with object 't1' with incompatible type or shape
p => t1
end select
More information about the flang-commits
mailing list