Skip to content

Commit 78af31a

Browse files
klauslerAlexisPerry
klausler
authored and
AlexisPerry
committed
[flang] Add/fix some semantic checks for assumed-rank (llvm#96194)
Catch some cases where assumed rank dummy arguments are not allowed.
1 parent 432efcb commit 78af31a

File tree

7 files changed

+49
-17
lines changed

7 files changed

+49
-17
lines changed

‎flang/include/flang/Evaluate/tools.h

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,9 @@ template <typename T> bool IsAssumedRank(const Expr<T> &expr) {
9898
template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
9999
return x && IsAssumedRank(*x);
100100
}
101+
template <typename A> bool IsAssumedRank(const A *x) {
102+
return x && IsAssumedRank(*x);
103+
}
101104

102105
// Predicate: true when an expression is a coarray (corank > 0)
103106
bool IsCoarray(const ActualArgument &);

‎flang/lib/Semantics/check-allocate.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -539,7 +539,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
539539
// Shape related checks
540540
if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
541541
context.Say(name_.source,
542-
"An assumed-rank object may not appear in an ALLOCATE statement"_err_en_US);
542+
"An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
543543
return false;
544544
}
545545
if (ultimate_ && IsAssumedSizeArray(*ultimate_) && context.AnyFatalError()) {

‎flang/lib/Semantics/check-call.cpp

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -67,11 +67,9 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
6767
messages.Say(
6868
"Coarray argument requires an explicit interface"_err_en_US);
6969
}
70-
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
71-
if (details->IsAssumedRank()) {
72-
messages.Say(
73-
"Assumed rank argument requires an explicit interface"_err_en_US);
74-
}
70+
if (evaluate::IsAssumedRank(symbol)) {
71+
messages.Say(
72+
"Assumed rank argument requires an explicit interface"_err_en_US);
7573
}
7674
if (symbol.attrs().test(Attr::ASYNCHRONOUS)) {
7775
messages.Say(

‎flang/lib/Semantics/check-declarations.cpp

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -252,8 +252,7 @@ void CheckHelper::Check(const Symbol &symbol) {
252252
&symbol == &symbol.GetUltimate()) {
253253
if (context_.ShouldWarn(common::LanguageFeature::LongNames)) {
254254
WarnIfNotInModuleFile(symbol.name(),
255-
"%s has length %d, which is greater than the maximum name length "
256-
"%d"_port_en_US,
255+
"%s has length %d, which is greater than the maximum name length %d"_port_en_US,
257256
symbol.name(), symbol.name().size(), common::maxNameLen);
258257
}
259258
}
@@ -466,11 +465,16 @@ void CheckHelper::Check(const Symbol &symbol) {
466465
symbol.name());
467466
}
468467
}
469-
if (IsProcedure(symbol) && !symbol.HasExplicitInterface() &&
470-
symbol.Rank() > 0) {
471-
messages_.Say(
472-
"Procedure '%s' may not be an array without an explicit interface"_err_en_US,
473-
symbol.name());
468+
if (IsProcedure(symbol)) {
469+
if (IsAllocatable(symbol)) {
470+
messages_.Say(
471+
"Procedure '%s' may not be ALLOCATABLE"_err_en_US, symbol.name());
472+
}
473+
if (!symbol.HasExplicitInterface() && symbol.Rank() > 0) {
474+
messages_.Say(
475+
"Procedure '%s' may not be an array without an explicit interface"_err_en_US,
476+
symbol.name());
477+
}
474478
}
475479
}
476480

‎flang/lib/Semantics/expression.cpp

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,7 @@ class ArgumentAnalyzer {
153153
bool CheckConformance();
154154
bool CheckAssignmentConformance();
155155
bool CheckForNullPointer(const char *where = "as an operand here");
156+
bool CheckForAssumedRank(const char *where = "as an operand here");
156157

157158
// Find and return a user-defined operator or report an error.
158159
// The provided message is used if there is no such operator.
@@ -3200,6 +3201,7 @@ const Assignment *ExpressionAnalyzer::Analyze(const parser::AssignmentStmt &x) {
32003201
if (!procRef) {
32013202
analyzer.CheckForNullPointer(
32023203
"in a non-pointer intrinsic assignment statement");
3204+
analyzer.CheckForAssumedRank("in an assignment statement");
32033205
const Expr<SomeType> &lhs{analyzer.GetExpr(0)};
32043206
if (auto dyType{lhs.GetType()};
32053207
dyType && dyType->IsPolymorphic()) { // 10.2.1.2p1(1)
@@ -3394,6 +3396,7 @@ static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
33943396
if (!analyzer.fatalErrors()) {
33953397
if (analyzer.IsIntrinsicNumeric(opr)) {
33963398
analyzer.CheckForNullPointer();
3399+
analyzer.CheckForAssumedRank();
33973400
if (opr == NumericOperator::Add) {
33983401
return analyzer.MoveExpr(0);
33993402
} else {
@@ -3428,6 +3431,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
34283431
if (!analyzer.fatalErrors()) {
34293432
if (analyzer.IsIntrinsicLogical()) {
34303433
analyzer.CheckForNullPointer();
3434+
analyzer.CheckForAssumedRank();
34313435
return AsGenericExpr(
34323436
LogicalNegation(std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u)));
34333437
} else {
@@ -3476,6 +3480,7 @@ MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
34763480
if (!analyzer.fatalErrors()) {
34773481
if (analyzer.IsIntrinsicNumeric(opr)) {
34783482
analyzer.CheckForNullPointer();
3483+
analyzer.CheckForAssumedRank();
34793484
analyzer.CheckConformance();
34803485
return NumericOperation<OPR>(context.GetContextualMessages(),
34813486
analyzer.MoveExpr(0), analyzer.MoveExpr(1),
@@ -3525,6 +3530,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Concat &x) {
35253530
if (!analyzer.fatalErrors()) {
35263531
if (analyzer.IsIntrinsicConcat()) {
35273532
analyzer.CheckForNullPointer();
3533+
analyzer.CheckForAssumedRank();
35283534
return common::visit(
35293535
[&](auto &&x, auto &&y) -> MaybeExpr {
35303536
using T = ResultType<decltype(x)>;
@@ -3572,6 +3578,7 @@ MaybeExpr RelationHelper(ExpressionAnalyzer &context, RelationalOperator opr,
35723578
if (leftType && rightType &&
35733579
analyzer.IsIntrinsicRelational(opr, *leftType, *rightType)) {
35743580
analyzer.CheckForNullPointer("as a relational operand");
3581+
analyzer.CheckForAssumedRank("as a relational operand");
35753582
return AsMaybeExpr(Relate(context.GetContextualMessages(), opr,
35763583
analyzer.MoveExpr(0), analyzer.MoveExpr(1)));
35773584
} else {
@@ -3617,6 +3624,7 @@ MaybeExpr LogicalBinaryHelper(ExpressionAnalyzer &context, LogicalOperator opr,
36173624
if (!analyzer.fatalErrors()) {
36183625
if (analyzer.IsIntrinsicLogical()) {
36193626
analyzer.CheckForNullPointer("as a logical operand");
3627+
analyzer.CheckForAssumedRank("as a logical operand");
36203628
return AsGenericExpr(BinaryLogicalOperation(opr,
36213629
std::get<Expr<SomeLogical>>(analyzer.MoveExpr(0).u),
36223630
std::get<Expr<SomeLogical>>(analyzer.MoveExpr(1).u)));
@@ -4330,6 +4338,18 @@ bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
43304338
return true;
43314339
}
43324340

4341+
bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
4342+
for (const std::optional<ActualArgument> &arg : actuals_) {
4343+
if (arg && IsAssumedRank(arg->UnwrapExpr())) {
4344+
context_.Say(source_,
4345+
"An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
4346+
fatalErrors_ = true;
4347+
return false;
4348+
}
4349+
}
4350+
return true;
4351+
}
4352+
43334353
MaybeExpr ArgumentAnalyzer::TryDefinedOp(
43344354
const char *opr, parser::MessageFixedText error, bool isUserOp) {
43354355
if (AnyUntypedOrMissingOperand()) {
@@ -4404,7 +4424,7 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(
44044424
context_.Say(
44054425
"Operands of %s are not conformable; have rank %d and rank %d"_err_en_US,
44064426
ToUpperCase(opr), actuals_[0]->Rank(), actuals_[1]->Rank());
4407-
} else if (CheckForNullPointer()) {
4427+
} else if (CheckForNullPointer() && CheckForAssumedRank()) {
44084428
context_.Say(error, ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
44094429
}
44104430
return result;

‎flang/lib/Semantics/pointer-assignment.cpp

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -148,6 +148,9 @@ bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
148148
msg->Attach(std::move(*whyNot));
149149
}
150150
return false;
151+
} else if (evaluate::IsAssumedRank(lhs)) {
152+
Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US);
153+
return false;
151154
} else {
152155
return true;
153156
}

‎flang/test/Semantics/select-rank03.f90

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -52,10 +52,12 @@ subroutine allocatables(a)
5252
!ERROR: Whole assumed-size array 'a' may not appear here without subscripts
5353
a = 1.
5454
rank default
55-
!ERROR: An assumed-rank object may not appear in an ALLOCATE statement
55+
!ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
5656
allocate(a)
5757
deallocate(a)
58-
a = 1.
58+
!ERROR: An assumed-rank dummy argument is not allowed in an assignment statement
59+
!ERROR: An assumed-rank dummy argument is not allowed as an operand here
60+
a = a + 1.
5961
end select
6062
! Test nested associations
6163
select rank(a)
@@ -121,11 +123,13 @@ subroutine pointers(p)
121123
!ERROR: Whole assumed-size array 'p' may not appear here without subscripts
122124
deallocate(p)
123125
rank default
124-
!ERROR: An assumed-rank object may not appear in an ALLOCATE statement
126+
!ERROR: An assumed-rank dummy argument may not appear in an ALLOCATE statement
125127
allocate(p)
126128
deallocate(p)
129+
!ERROR: The left-hand side of a pointer assignment must not be an assumed-rank dummy argument
127130
!ERROR: pointer 'p' associated with object 't0' with incompatible type or shape
128131
p => t0
132+
!ERROR: The left-hand side of a pointer assignment must not be an assumed-rank dummy argument
129133
!ERROR: pointer 'p' associated with object 't1' with incompatible type or shape
130134
p => t1
131135
end select

0 commit comments

Comments
 (0)