Skip to content

Commit f9b089a

Browse files
klauslerklausler
authored
[flang] Fix semantic checks for MOVE_ALLOC (#77362)
The checking of calls to the intrinsic subroutine MOVE_ALLOC is not insisting that its first two arguments be whole allocatable variables or components. Fix, move the code into check-calls.cpp (a better home for such things), and clean up the tests. Fixes #77230.
1 parent f089691 commit f9b089a

File tree

5 files changed

+89
-61
lines changed

5 files changed

+89
-61
lines changed

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1192,6 +1192,10 @@ class ArrayConstantBoundChanger {
11921192
std::optional<bool> AreEquivalentInInterface(
11931193
const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
11941194

1195+
bool CheckForCoindexedObject(parser::ContextualMessages &,
1196+
const std::optional<ActualArgument> &, const std::string &procName,
1197+
const std::string &argName);
1198+
11951199
} // namespace Fortran::evaluate
11961200

11971201
namespace Fortran::semantics {

‎flang/lib/Evaluate/intrinsics.cpp‎

Lines changed: 14 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -2727,28 +2727,13 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
27272727
}
27282728
}
27292729

2730-
static bool CheckForCoindexedObject(FoldingContext &context,
2731-
const std::optional<ActualArgument> &arg, const std::string &procName,
2732-
const std::string &argName) {
2733-
bool ok{true};
2734-
if (arg) {
2735-
if (ExtractCoarrayRef(arg->UnwrapExpr())) {
2736-
ok = false;
2737-
context.messages().Say(arg->sourceLocation(),
2738-
"'%s' argument to '%s' may not be a coindexed object"_err_en_US,
2739-
argName, procName);
2740-
}
2741-
}
2742-
return ok;
2743-
}
2744-
27452730
// Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
27462731
std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
27472732
ActualArguments &arguments, FoldingContext &context) const {
27482733
static const char *const keywords[]{"x", nullptr};
27492734
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
27502735
CHECK(arguments.size() == 1);
2751-
CheckForCoindexedObject(context, arguments[0], "c_loc", "x");
2736+
CheckForCoindexedObject(context.messages(), arguments[0], "c_loc", "x");
27522737
const auto *expr{arguments[0].value().UnwrapExpr()};
27532738
if (expr &&
27542739
!(IsObjectPointer(*expr) ||
@@ -2876,7 +2861,7 @@ static bool CheckAtomicDefineAndRef(FoldingContext &context,
28762861
}
28772862

28782863
return sameType &&
2879-
CheckForCoindexedObject(context, statArg, procName, "stat");
2864+
CheckForCoindexedObject(context.messages(), statArg, procName, "stat");
28802865
}
28812866

28822867
// Applies any semantic checks peculiar to an intrinsic.
@@ -2900,25 +2885,29 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
29002885
// Now handled in Semantics/check-call.cpp
29012886
} else if (name == "atomic_and" || name == "atomic_or" ||
29022887
name == "atomic_xor") {
2903-
return CheckForCoindexedObject(context, call.arguments[2], name, "stat");
2888+
return CheckForCoindexedObject(
2889+
context.messages(), call.arguments[2], name, "stat");
29042890
} else if (name == "atomic_cas") {
2905-
return CheckForCoindexedObject(context, call.arguments[4], name, "stat");
2891+
return CheckForCoindexedObject(
2892+
context.messages(), call.arguments[4], name, "stat");
29062893
} else if (name == "atomic_define") {
29072894
return CheckAtomicDefineAndRef(
29082895
context, call.arguments[0], call.arguments[1], call.arguments[2], name);
29092896
} else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" ||
29102897
name == "atomic_fetch_or" || name == "atomic_fetch_xor") {
2911-
return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
2898+
return CheckForCoindexedObject(
2899+
context.messages(), call.arguments[3], name, "stat");
29122900
} else if (name == "atomic_ref") {
29132901
return CheckAtomicDefineAndRef(
29142902
context, call.arguments[1], call.arguments[0], call.arguments[2], name);
29152903
} else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
29162904
name == "co_sum") {
2917-
bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")};
2918-
bool statOk{
2919-
CheckForCoindexedObject(context, call.arguments[2], name, "stat")};
2920-
bool errmsgOk{
2921-
CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")};
2905+
bool aOk{CheckForCoindexedObject(
2906+
context.messages(), call.arguments[0], name, "a")};
2907+
bool statOk{CheckForCoindexedObject(
2908+
context.messages(), call.arguments[2], name, "stat")};
2909+
bool errmsgOk{CheckForCoindexedObject(
2910+
context.messages(), call.arguments[3], name, "errmsg")};
29222911
ok = aOk && statOk && errmsgOk;
29232912
} else if (name == "image_status") {
29242913
if (const auto &arg{call.arguments[0]}) {
@@ -2935,29 +2924,6 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
29352924
arg ? arg->sourceLocation() : context.messages().at(),
29362925
"Argument of LOC() must be an object or procedure"_err_en_US);
29372926
}
2938-
} else if (name == "move_alloc") {
2939-
ok &= CheckForCoindexedObject(context, call.arguments[0], name, "from");
2940-
ok &= CheckForCoindexedObject(context, call.arguments[1], name, "to");
2941-
ok &= CheckForCoindexedObject(context, call.arguments[2], name, "stat");
2942-
ok &= CheckForCoindexedObject(context, call.arguments[3], name, "errmsg");
2943-
if (call.arguments[0] && call.arguments[1]) {
2944-
for (int j{0}; j < 2; ++j) {
2945-
if (const Symbol *last{GetLastSymbol(call.arguments[j])};
2946-
last && !IsAllocatable(last->GetUltimate())) {
2947-
context.messages().Say(call.arguments[j]->sourceLocation(),
2948-
"Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US,
2949-
j + 1);
2950-
ok = false;
2951-
}
2952-
}
2953-
auto type0{call.arguments[0]->GetType()};
2954-
auto type1{call.arguments[1]->GetType()};
2955-
if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
2956-
context.messages().Say(call.arguments[1]->sourceLocation(),
2957-
"When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
2958-
ok = false;
2959-
}
2960-
}
29612927
} else if (name == "present") {
29622928
const auto &arg{call.arguments[0]};
29632929
if (arg) {

‎flang/lib/Evaluate/tools.cpp‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1353,6 +1353,19 @@ std::optional<bool> AreEquivalentInInterface(
13531353
}
13541354
}
13551355

1356+
bool CheckForCoindexedObject(parser::ContextualMessages &messages,
1357+
const std::optional<ActualArgument> &arg, const std::string &procName,
1358+
const std::string &argName) {
1359+
if (arg && ExtractCoarrayRef(arg->UnwrapExpr())) {
1360+
messages.Say(arg->sourceLocation(),
1361+
"'%s' argument to '%s' may not be a coindexed object"_err_en_US,
1362+
argName, procName);
1363+
return false;
1364+
} else {
1365+
return true;
1366+
}
1367+
}
1368+
13561369
} // namespace Fortran::evaluate
13571370

13581371
namespace Fortran::semantics {

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

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1431,6 +1431,43 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
14311431
}
14321432
}
14331433

1434+
// MOVE_ALLOC (F'2023 16.9.147)
1435+
static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
1436+
parser::ContextualMessages &messages) {
1437+
if (arguments.size() >= 1) {
1438+
evaluate::CheckForCoindexedObject(
1439+
messages, arguments[0], "move_alloc", "from");
1440+
}
1441+
if (arguments.size() >= 2) {
1442+
evaluate::CheckForCoindexedObject(
1443+
messages, arguments[1], "move_alloc", "to");
1444+
}
1445+
if (arguments.size() >= 3) {
1446+
evaluate::CheckForCoindexedObject(
1447+
messages, arguments[2], "move_alloc", "stat");
1448+
}
1449+
if (arguments.size() >= 4) {
1450+
evaluate::CheckForCoindexedObject(
1451+
messages, arguments[3], "move_alloc", "errmsg");
1452+
}
1453+
if (arguments.size() >= 2 && arguments[0] && arguments[1]) {
1454+
for (int j{0}; j < 2; ++j) {
1455+
if (const Symbol *
1456+
whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])};
1457+
!whole || !IsAllocatable(whole->GetUltimate())) {
1458+
messages.Say(*arguments[j]->sourceLocation(),
1459+
"Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1);
1460+
}
1461+
}
1462+
auto type0{arguments[0]->GetType()};
1463+
auto type1{arguments[1]->GetType()};
1464+
if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
1465+
messages.Say(arguments[1]->sourceLocation(),
1466+
"When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
1467+
}
1468+
}
1469+
}
1470+
14341471
// REDUCE (F'2023 16.9.173)
14351472
static void CheckReduce(
14361473
evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
@@ -1639,6 +1676,8 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
16391676
const evaluate::SpecificIntrinsic &intrinsic) {
16401677
if (intrinsic.name == "associated") {
16411678
CheckAssociated(arguments, context, scope);
1679+
} else if (intrinsic.name == "move_alloc") {
1680+
CheckMove_Alloc(arguments, context.foldingContext().messages());
16421681
} else if (intrinsic.name == "reduce") {
16431682
CheckReduce(arguments, context.foldingContext());
16441683
} else if (intrinsic.name == "transfer") {

‎flang/test/Semantics/move_alloc.f90‎

Lines changed: 19 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,11 @@
11
! RUN: %python %S/test_errors.py %s %flang_fc1
22
! Check for semantic errors in move_alloc() subroutine calls
33
program main
4-
integer, allocatable :: a(:)[:], b(:)[:], c(:)[:], d(:)[:], f(:)
4+
integer, allocatable :: a(:)[:], b(:)[:], f(:), g(:)
5+
type alloc_component
6+
integer, allocatable :: a(:)
7+
end type
8+
type(alloc_component) :: c[*], d[*]
59
!ERROR: 'e' is an ALLOCATABLE coarray and must have a deferred coshape
610
integer, allocatable :: e(:)[*]
711
integer status, coindexed_status[*]
@@ -18,42 +22,39 @@ program main
1822
a = [ 1, 2, 3 ]
1923
call move_alloc(a, b, status, message)
2024

21-
allocate(c(3)[*])
22-
c = [ 1, 2, 3 ]
23-
2425
!ERROR: too many actual arguments for intrinsic 'move_alloc'
2526
call move_alloc(a, b, status, message, 1)
2627

2728
! standards non-conforming
2829
!ERROR: 'from' argument to 'move_alloc' may not be a coindexed object
29-
call move_alloc(c[1], d)
30+
call move_alloc(c[1]%a, f)
3031

3132
!ERROR: 'to' argument to 'move_alloc' may not be a coindexed object
32-
call move_alloc(c, d[1])
33+
call move_alloc(f, d[1]%a)
3334

3435
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
35-
call move_alloc(c, d, coindexed_status[1])
36+
call move_alloc(f, g, coindexed_status[1])
3637

3738
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
38-
call move_alloc(c, d, status, coindexed_message[1])
39+
call move_alloc(f, g, status, coindexed_message[1])
3940

4041
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
41-
call move_alloc(c, d, errmsg=coindexed_message[1])
42+
call move_alloc(f, g, errmsg=coindexed_message[1])
4243

4344
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
44-
call move_alloc(c, d, errmsg=coindexed_message[1], stat=status)
45+
call move_alloc(f, g, errmsg=coindexed_message[1], stat=status)
4546

4647
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
47-
call move_alloc(c, d, stat=coindexed_status[1])
48+
call move_alloc(f, g, stat=coindexed_status[1])
4849

4950
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
50-
call move_alloc(c, d, errmsg=message, stat=coindexed_status[1])
51+
call move_alloc(f, g, errmsg=message, stat=coindexed_status[1])
5152

5253
!ERROR: 'from' argument to 'move_alloc' may not be a coindexed object
5354
!ERROR: 'to' argument to 'move_alloc' may not be a coindexed object
5455
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
5556
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
56-
call move_alloc(c[1], d[1], stat=coindexed_status[1], errmsg=coindexed_message[1])
57+
call move_alloc(c[1]%a, d[1]%a, stat=coindexed_status[1], errmsg=coindexed_message[1])
5758

5859
!ERROR: Argument #1 to MOVE_ALLOC must be allocatable
5960
call move_alloc(nonAllocatable, f)
@@ -67,4 +68,9 @@ program main
6768
!ERROR: Actual argument for 'to=' has bad type or kind 'CHARACTER(KIND=1,LEN=3_8)'
6869
call move_alloc(ca, cb)
6970

71+
!ERROR: Argument #1 to MOVE_ALLOC must be allocatable
72+
call move_alloc(f(::2), g)
73+
!ERROR: Argument #2 to MOVE_ALLOC must be allocatable
74+
call move_alloc(f, g(::2))
75+
7076
end program main

0 commit comments

Comments
 (0)