[flang-commits] [PATCH] D136973: [flang] Stricter scrutiny of MOVE_ALLOC calls

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: vdonaldson.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D136973

Files:
  flang/lib/Evaluate/intrinsics.cpp
  flang/test/Semantics/move_alloc.f90


Index: flang/test/Semantics/move_alloc.f90
===================================================================
--- flang/test/Semantics/move_alloc.f90
+++ flang/test/Semantics/move_alloc.f90
@@ -1,11 +1,17 @@
 ! 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[*]
+  character, allocatable :: ca*2, cb*3
+  integer :: nonAllocatable(10)
+  type t
+  end type
+  class(t), allocatable :: t1
+  type(t), allocatable :: t2
 
   ! standards conforming
   allocate(a(3)[*])
@@ -49,4 +55,16 @@
   !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: 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(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
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ flang/lib/Evaluate/intrinsics.cpp
@@ -2728,14 +2728,28 @@
           "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) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D136973.471625.patch
Type: text/x-patch
Size: 3471 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20221028/bf742180/attachment-0001.bin>