diff options
author | Peter Klausler <35819229+klausler@users.noreply.github.com> | 2024-01-15 11:57:37 -0800 |
---|---|---|
committer | GitHub <noreply@github.com> | 2024-01-15 11:57:37 -0800 |
commit | f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1 (patch) | |
tree | c4d5ec9601ce24d79960e5fbaca59d4afb64cc62 | |
parent | f0896911570eae97507f9e3ccf2732182404981e (diff) | |
download | llvm-f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1.zip llvm-f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1.tar.gz llvm-f9b089a7c01dd3fe7de3d397520172ec3b8fb9f1.tar.bz2 |
[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.
-rw-r--r-- | flang/include/flang/Evaluate/tools.h | 4 | ||||
-rw-r--r-- | flang/lib/Evaluate/intrinsics.cpp | 62 | ||||
-rw-r--r-- | flang/lib/Evaluate/tools.cpp | 13 | ||||
-rw-r--r-- | flang/lib/Semantics/check-call.cpp | 39 | ||||
-rw-r--r-- | flang/test/Semantics/move_alloc.f90 | 32 |
5 files changed, 89 insertions, 61 deletions
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index c0cbb05..056bad5 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1192,6 +1192,10 @@ private: 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 08cec73..da6d5970 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 7834364..e57058c 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 ec8f99c..a8927e9 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 a67fdca..3303a00 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 |