[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.

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