[flang] [FORALL] Incorrect dynamic type assigned within FORALL

[DanielCChen]

Consider the following reducer:

  PROGRAM main
  IMPLICIT NONE
  TYPE :: DT
    CLASS(DT), POINTER    :: Ptr(:) => NULL()
  END TYPE

  TYPE, EXTENDS(DT) :: DT1
  END TYPE

  TYPE(DT1), TARGET  :: Tar1(100)
  CLASS(DT), POINTER :: T(:)
  integer :: I

  ALLOCATE(T(10))

  !DO I = 1, 10
  FORALL (I=1:10)            !! Wrong dynamic type assigned to T(I)%Ptr.
    T(I)%Ptr => Tar1
  END FORALL
  !end do

  DO I = 1, 10
    SELECT TYPE (aa => T(I)%Ptr)
    TYPE IS (DT1)
      print*, "in type is"
    CLASS DEFAULT
      print*, "in class default"
    END SELECT
  END DO

  END

Flang outputs

> a.out
 in class default
 in class default
 in class default
 in class default
 in class default
 in class default
 in class default
 in class default
 in class default
 in class default

The expected output is

> a.out
 in type is
 in type is
 in type is
 in type is
 in type is
 in type is
 in type is
 in type is
 in type is
 in type is

If I replace FORALL with the DO loop, Flang executes successfully.

[llvmbot]

@llvm/issue-subscribers-flang-frontend

Author: Daniel Chen (DanielCChen)

Consider the following reducer: ``` PROGRAM main IMPLICIT NONE TYPE :: DT CLASS(DT), POINTER :: Ptr(:) => NULL() END TYPE

TYPE, EXTENDS(DT) :: DT1
END TYPE

TYPE(DT1), TARGET :: Tar1(100)
CLASS(DT), POINTER :: T(:)
integer :: I

ALLOCATE(T(10))

!DO I = 1, 10
FORALL (I=1:10) !! Wrong dynamic type assigned to T(I)%Ptr.
T(I)%Ptr => Tar1
END FORALL
!end do

DO I = 1, 10
SELECT TYPE (aa => T(I)%Ptr)
TYPE IS (DT1)
print*, "in type is"
CLASS DEFAULT
print*, "in class default"
END SELECT
END DO

END

Flang outputs 

> a.out
in class default
in class default
in class default
in class default
in class default
in class default
in class default
in class default
in class default
in class default

The expected output is

> a.out
in type is
in type is
in type is
in type is
in type is
in type is
in type is
in type is
in type is
in type is

If I replace `FORALL` with the `DO` loop, Flang executes successfully.

</details>

[jeanPerier]

The issue here is that lowering is preparing the RHS descriptor in the Forall assignment statement using the LHS declared type, which is not valid for polymorphic pointers:

     hlfir.region_assign {
        %64 = fir.convert %8#0 : (!fir.ref<!fir.array<100x!fir.type<_QFTdt1{dt:!fir.type<_QFTdt{ptr:!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt>>>>}>}>>>) -> !fir.ref<!fir.array<?x!fir.type<_QFTdt{ptr:!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt>>>>}>>>
        %65 = fir.embox %64(%7) : (!fir.ref<!fir.array<?x!fir.type<_QFTdt{ptr:!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt>>>>}>>>, !fir.shape<1>) -> !fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt{ptr:!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt>>>>}>>>>
        hlfir.yield %65 : !fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt{ptr:!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFTdt>>>>}>>>> 
      } to {

llvm-project/flang/lib/Lower/Bridge.cpp

Line 4661 in 39572f5

loc, *builder, rhs, lhsBoxType.getBoxTypeWithNewShape(rhs.getRank()));