[flang-commits] [flang] f9b089a - [flang] Fix semantic checks for MOVE_ALLOC (#77362)
via flang-commits
flang-commits at lists.llvm.org
Mon Jan 15 11:57:41 PST 2024
Author: Peter Klausler
Date: 2024-01-15T11:57:37-08:00
New Revision: f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1
URL: https://github.com/llvm/llvm-project/commit/f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1
DIFF: https://github.com/llvm/llvm-project/commit/f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1.diff
LOG: [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 https://github.com/llvm/llvm-project/issues/77230.
Added:
Modified:
flang/include/flang/Evaluate/tools.h
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/move_alloc.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index c0cbb05c009d6b..056bad5e0d6988 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1192,6 +1192,10 @@ class ArrayConstantBoundChanger {
std::optional<bool> AreEquivalentInInterface(
const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
+bool CheckForCoindexedObject(parser::ContextualMessages &,
+ const std::optional<ActualArgument> &, const std::string &procName,
+ const std::string &argName);
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 08cec73d88ced2..da6d5970089884 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2727,28 +2727,13 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
-static bool CheckForCoindexedObject(FoldingContext &context,
- const std::optional<ActualArgument> &arg, const std::string &procName,
- const std::string &argName) {
- bool ok{true};
- if (arg) {
- if (ExtractCoarrayRef(arg->UnwrapExpr())) {
- ok = false;
- context.messages().Say(arg->sourceLocation(),
- "'%s' argument to '%s' may not be a coindexed object"_err_en_US,
- argName, procName);
- }
- }
- return ok;
-}
-
// Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
ActualArguments &arguments, FoldingContext &context) const {
static const char *const keywords[]{"x", nullptr};
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
CHECK(arguments.size() == 1);
- CheckForCoindexedObject(context, arguments[0], "c_loc", "x");
+ CheckForCoindexedObject(context.messages(), arguments[0], "c_loc", "x");
const auto *expr{arguments[0].value().UnwrapExpr()};
if (expr &&
!(IsObjectPointer(*expr) ||
@@ -2876,7 +2861,7 @@ static bool CheckAtomicDefineAndRef(FoldingContext &context,
}
return sameType &&
- CheckForCoindexedObject(context, statArg, procName, "stat");
+ CheckForCoindexedObject(context.messages(), statArg, procName, "stat");
}
// Applies any semantic checks peculiar to an intrinsic.
@@ -2900,25 +2885,29 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
// Now handled in Semantics/check-call.cpp
} else if (name == "atomic_and" || name == "atomic_or" ||
name == "atomic_xor") {
- return CheckForCoindexedObject(context, call.arguments[2], name, "stat");
+ return CheckForCoindexedObject(
+ context.messages(), call.arguments[2], name, "stat");
} else if (name == "atomic_cas") {
- return CheckForCoindexedObject(context, call.arguments[4], name, "stat");
+ return CheckForCoindexedObject(
+ context.messages(), call.arguments[4], name, "stat");
} else if (name == "atomic_define") {
return CheckAtomicDefineAndRef(
context, call.arguments[0], call.arguments[1], call.arguments[2], name);
} else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" ||
name == "atomic_fetch_or" || name == "atomic_fetch_xor") {
- return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
+ return CheckForCoindexedObject(
+ context.messages(), call.arguments[3], name, "stat");
} else if (name == "atomic_ref") {
return CheckAtomicDefineAndRef(
context, call.arguments[1], call.arguments[0], call.arguments[2], name);
} else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
name == "co_sum") {
- bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")};
- bool statOk{
- CheckForCoindexedObject(context, call.arguments[2], name, "stat")};
- bool errmsgOk{
- CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")};
+ bool aOk{CheckForCoindexedObject(
+ context.messages(), call.arguments[0], name, "a")};
+ bool statOk{CheckForCoindexedObject(
+ context.messages(), call.arguments[2], name, "stat")};
+ bool errmsgOk{CheckForCoindexedObject(
+ context.messages(), call.arguments[3], name, "errmsg")};
ok = aOk && statOk && errmsgOk;
} else if (name == "image_status") {
if (const auto &arg{call.arguments[0]}) {
@@ -2935,29 +2924,6 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
arg ? arg->sourceLocation() : context.messages().at(),
"Argument of LOC() must be an object or procedure"_err_en_US);
}
- } else if (name == "move_alloc") {
- ok &= CheckForCoindexedObject(context, call.arguments[0], name, "from");
- ok &= CheckForCoindexedObject(context, call.arguments[1], name, "to");
- ok &= CheckForCoindexedObject(context, call.arguments[2], name, "stat");
- ok &= CheckForCoindexedObject(context, call.arguments[3], name, "errmsg");
- if (call.arguments[0] && call.arguments[1]) {
- for (int j{0}; j < 2; ++j) {
- if (const Symbol *last{GetLastSymbol(call.arguments[j])};
- last && !IsAllocatable(last->GetUltimate())) {
- context.messages().Say(call.arguments[j]->sourceLocation(),
- "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US,
- j + 1);
- ok = false;
- }
- }
- auto type0{call.arguments[0]->GetType()};
- auto type1{call.arguments[1]->GetType()};
- if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
- context.messages().Say(call.arguments[1]->sourceLocation(),
- "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
- ok = false;
- }
- }
} else if (name == "present") {
const auto &arg{call.arguments[0]};
if (arg) {
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 7834364bccc400..e57058c7ac1479 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1353,6 +1353,19 @@ std::optional<bool> AreEquivalentInInterface(
}
}
+bool CheckForCoindexedObject(parser::ContextualMessages &messages,
+ const std::optional<ActualArgument> &arg, const std::string &procName,
+ const std::string &argName) {
+ if (arg && ExtractCoarrayRef(arg->UnwrapExpr())) {
+ messages.Say(arg->sourceLocation(),
+ "'%s' argument to '%s' may not be a coindexed object"_err_en_US,
+ argName, procName);
+ return false;
+ } else {
+ return true;
+ }
+}
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index ec8f99ca6bf48e..a8927e94481d4b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1431,6 +1431,43 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
}
}
+// MOVE_ALLOC (F'2023 16.9.147)
+static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
+ parser::ContextualMessages &messages) {
+ if (arguments.size() >= 1) {
+ evaluate::CheckForCoindexedObject(
+ messages, arguments[0], "move_alloc", "from");
+ }
+ if (arguments.size() >= 2) {
+ evaluate::CheckForCoindexedObject(
+ messages, arguments[1], "move_alloc", "to");
+ }
+ if (arguments.size() >= 3) {
+ evaluate::CheckForCoindexedObject(
+ messages, arguments[2], "move_alloc", "stat");
+ }
+ if (arguments.size() >= 4) {
+ evaluate::CheckForCoindexedObject(
+ messages, arguments[3], "move_alloc", "errmsg");
+ }
+ if (arguments.size() >= 2 && arguments[0] && arguments[1]) {
+ for (int j{0}; j < 2; ++j) {
+ if (const Symbol *
+ whole{UnwrapWholeSymbolOrComponentDataRef(arguments[j])};
+ !whole || !IsAllocatable(whole->GetUltimate())) {
+ messages.Say(*arguments[j]->sourceLocation(),
+ "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, j + 1);
+ }
+ }
+ auto type0{arguments[0]->GetType()};
+ auto type1{arguments[1]->GetType()};
+ if (type0 && type1 && type0->IsPolymorphic() && !type1->IsPolymorphic()) {
+ messages.Say(arguments[1]->sourceLocation(),
+ "When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic"_err_en_US);
+ }
+ }
+}
+
// REDUCE (F'2023 16.9.173)
static void CheckReduce(
evaluate::ActualArguments &arguments, evaluate::FoldingContext &context) {
@@ -1639,6 +1676,8 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
const evaluate::SpecificIntrinsic &intrinsic) {
if (intrinsic.name == "associated") {
CheckAssociated(arguments, context, scope);
+ } else if (intrinsic.name == "move_alloc") {
+ CheckMove_Alloc(arguments, context.foldingContext().messages());
} else if (intrinsic.name == "reduce") {
CheckReduce(arguments, context.foldingContext());
} else if (intrinsic.name == "transfer") {
diff --git a/flang/test/Semantics/move_alloc.f90 b/flang/test/Semantics/move_alloc.f90
index a67fdca9701e5e..3303a002039bb8 100644
--- a/flang/test/Semantics/move_alloc.f90
+++ b/flang/test/Semantics/move_alloc.f90
@@ -1,7 +1,11 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
! Check for semantic errors in move_alloc() subroutine calls
program main
- integer, allocatable :: a(:)[:], b(:)[:], c(:)[:], d(:)[:], f(:)
+ integer, allocatable :: a(:)[:], b(:)[:], f(:), g(:)
+ type alloc_component
+ integer, allocatable :: a(:)
+ end type
+ type(alloc_component) :: c[*], d[*]
!ERROR: 'e' is an ALLOCATABLE coarray and must have a deferred coshape
integer, allocatable :: e(:)[*]
integer status, coindexed_status[*]
@@ -18,42 +22,39 @@ program main
a = [ 1, 2, 3 ]
call move_alloc(a, b, status, message)
- allocate(c(3)[*])
- c = [ 1, 2, 3 ]
-
!ERROR: too many actual arguments for intrinsic 'move_alloc'
call move_alloc(a, b, status, message, 1)
! standards non-conforming
!ERROR: 'from' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c[1], d)
+ call move_alloc(c[1]%a, f)
!ERROR: 'to' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d[1])
+ call move_alloc(f, d[1]%a)
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, coindexed_status[1])
+ call move_alloc(f, g, coindexed_status[1])
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, status, coindexed_message[1])
+ call move_alloc(f, g, status, coindexed_message[1])
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, errmsg=coindexed_message[1])
+ call move_alloc(f, g, errmsg=coindexed_message[1])
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, errmsg=coindexed_message[1], stat=status)
+ call move_alloc(f, g, errmsg=coindexed_message[1], stat=status)
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, stat=coindexed_status[1])
+ call move_alloc(f, g, stat=coindexed_status[1])
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c, d, errmsg=message, stat=coindexed_status[1])
+ call move_alloc(f, g, errmsg=message, stat=coindexed_status[1])
!ERROR: 'from' argument to 'move_alloc' may not be a coindexed object
!ERROR: 'to' argument to 'move_alloc' may not be a coindexed object
!ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object
!ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object
- call move_alloc(c[1], d[1], stat=coindexed_status[1], errmsg=coindexed_message[1])
+ call move_alloc(c[1]%a, d[1]%a, stat=coindexed_status[1], errmsg=coindexed_message[1])
!ERROR: Argument #1 to MOVE_ALLOC must be allocatable
call move_alloc(nonAllocatable, f)
@@ -67,4 +68,9 @@ program main
!ERROR: Actual argument for 'to=' has bad type or kind 'CHARACTER(KIND=1,LEN=3_8)'
call move_alloc(ca, cb)
+ !ERROR: Argument #1 to MOVE_ALLOC must be allocatable
+ call move_alloc(f(::2), g)
+ !ERROR: Argument #2 to MOVE_ALLOC must be allocatable
+ call move_alloc(f, g(::2))
+
end program main
More information about the flang-commits
mailing list