From fd26eee486ed81a2477e28d069fb68072fd7b2a2 Mon Sep 17 00:00:00 2001
From: Valentin Clement <clementval@gmail.com>
Date: Thu, 19 Jan 2023 17:34:01 +0100
Subject: [PATCH] [flang] Allow pointer association between derived-type
 pointer and unlimited polymorphic target

Pointer association to unlimited polymorphic target is allowed for
unlimited polymorphic pointer and non-extensible derived-type.
This is checked by the semantic and this patch allows it in the
fir.rebox operation.

Reviewed By: jeanPerier, PeteSteinfeld

Differential Revision: https://reviews.llvm.org/D142104
---
 flang/lib/Optimizer/Dialect/FIROps.cpp |  1 +
 flang/test/Lower/polymorphic.f90       | 18 ++++++++++++++++++
 2 files changed, 19 insertions(+)

diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp
index b093f69..dcedff6 100644
--- a/flang/lib/Optimizer/Dialect/FIROps.cpp
+++ b/flang/lib/Optimizer/Dialect/FIROps.cpp
@@ -2322,6 +2322,7 @@ mlir::LogicalResult fir::ReboxOp::verify() {
     // character type.
     const bool typeCanMismatch =
         inputEleTy.isa<fir::RecordType>() || outEleTy.isa<mlir::NoneType>() ||
+        (inputEleTy.isa<mlir::NoneType>() && outEleTy.isa<fir::RecordType>()) ||
         (getSlice() && inputEleTy.isa<fir::CharacterType>()) ||
         areCompatibleCharacterTypes(inputEleTy, outEleTy);
     if (!typeCanMismatch)
diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90
index 8caa6ce..da843a2 100644
--- a/flang/test/Lower/polymorphic.f90
+++ b/flang/test/Lower/polymorphic.f90
@@ -44,6 +44,11 @@ module polymorphic_test
     type(p1) :: inner
   end type
 
+  type non_extensible
+    sequence
+    integer :: d
+  end type
+
   contains
 
   elemental subroutine assign_p1_int(lhs, rhs)
@@ -749,6 +754,19 @@ module polymorphic_test
 ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAInitialize(%[[BOX_NONE]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.box<none>, !fir.ref<i8>, i32) -> none
 
+  subroutine rebox_up_to_record_type(p)
+    class(*), allocatable, target :: p(:,:)
+    type(non_extensible), pointer :: t(:,:)
+    t => p
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPrebox_up_to_record_type(
+! CHECK-SAME: %[[P:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>> {fir.bindc_name = "p", fir.target}) {
+! CHECK: %[[T:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?x!fir.type<_QMpolymorphic_testTnon_extensible{d:i32}>>>> {bindc_name = "t", uniq_name = "_QMpolymorphic_testFrebox_up_to_record_typeEt"}
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
+! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD_P]](%{{.*}}) : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>, !fir.shift<2>) -> !fir.box<!fir.ptr<!fir.array<?x?x!fir.type<_QMpolymorphic_testTnon_extensible{d:i32}>>>>
+! CHECK: fir.store %[[REBOX]] to %[[T]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?x!fir.type<_QMpolymorphic_testTnon_extensible{d:i32}>>>>>
+
 end module
 
 program test
-- 
2.7.4