gcc/testsuite/gfortran.dg/class_67.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR78990 in which the scalarization of the assignment
   4 ! in the main program failed for two reasons: (i) The conversion of 'v1'
   5 ! into a class actual was being done after the call to 'return_t1', giving
   6 ! rise to the ICE reported in comment #1; and (ii) The 'info' descriptor,
   7 ! required for scalarization was not set, which gave rise to the ICE noted
   8 ! by the contributor.
   9 !
  10 ! Contributed by Chris Macmackin  <cmacmackin@gmail.com>
  11 !
  12 module test_type
  13   implicit none
  14
  15   type t1
  16      integer :: i
  17    contains
  18      procedure :: assign
  19      generic :: assignment(=) => assign
  20   end type t1
  21
  22 contains
  23
  24   elemental subroutine assign(this,rhs)
  25     class(t1), intent(inout) :: this
  26     class(t1), intent(in) :: rhs
  27     this%i = rhs%i
  28   end subroutine assign
  29
  30   function return_t1(arg)
  31     class(t1), dimension(:), intent(in) :: arg
  32     class(t1), dimension(:), allocatable :: return_t1
  33     allocate(return_t1(size(arg)), source=arg)
  34   end function return_t1
  35
  36   function return_t1_p(arg)
  37     class(t1), dimension(:), intent(in), target :: arg
  38     class(t1), dimension(:), pointer :: return_t1_p
  39     return_t1_p => arg
  40   end function return_t1_p
  41 end module test_type
  42
  43 program test
  44   use test_type
  45   implicit none
  46
  47   type(t1), dimension(3) :: v1, v2
  48   v1%i = [1,2,3]
  49   v2 = return_t1(v1)
  50   if (any (v2%i .ne. v1%i)) STOP 1
  51
  52   v1%i = [4,5,6]
  53   v2 = return_t1_p(v1)
  54   if (any (v2%i .ne. v1%i)) STOP 2
  55 end program test