[flang] Stricter scrutiny of MOVE_ALLOC calls

Enforce remaining semantic restrictions on the arguments to MOVE_ALLOC,
namely that the first two arguments must be allocatable (!) and that
if the source is polymorphic, so must the destination be.

Differential Revision: https://reviews.llvm.org/D136973

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index eec83f6..012bf00 100644 (file)
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2787,14 +2787,28 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
           "Argument of LOC() must be an object or procedure"_err_en_US);
     }
   } else if (name == "move_alloc") {
-    bool fromOk{
-        CheckForCoindexedObject(context, call.arguments[0], name, "from")};
-    bool toOk{CheckForCoindexedObject(context, call.arguments[1], name, "to")};
-    bool statOk{
-        CheckForCoindexedObject(context, call.arguments[2], name, "stat")};
-    bool errmsgOk{
-        CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")};
-    ok = fromOk && toOk && statOk && errmsgOk;
+    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/test/Semantics/move_alloc.f90 b/flang/test/Semantics/move_alloc.f90
index a8e1249..b1c5637 100644 (file)
--- a/flang/test/Semantics/move_alloc.f90
+++ b/flang/test/Semantics/move_alloc.f90
@@ -1,11 +1,16 @@
 ! 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(:)[:]
+  integer, allocatable :: a(:)[:], b(:)[:], c(:)[:], d(:)[:], f(:)
   !ERROR: 'e' is an ALLOCATABLE coarray and must have a deferred coshape
   integer, allocatable :: e(:)[*]
   integer status, coindexed_status[*]
   character(len=1) message, coindexed_message[*]
+  integer :: nonAllocatable(10)
+  type t
+  end type
+  class(t), allocatable :: t1
+  type(t), allocatable :: t2
 
   ! standards conforming
   allocate(a(3)[*])
@@ -49,4 +54,13 @@ program main
   !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])
 
+  !ERROR: Argument #1 to MOVE_ALLOC must be allocatable
+  call move_alloc(nonAllocatable, f)
+  !ERROR: Argument #2 to MOVE_ALLOC must be allocatable
+  call move_alloc(f, nonAllocatable)
+
+  !ERROR: When MOVE_ALLOC(FROM=) is polymorphic, TO= must also be polymorphic
+  call move_alloc(t1, t2)
+  call move_alloc(t2, t1) ! ok
+
 end program main