gcc/testsuite/gfortran.dg/assumed_rank_10.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! PR fortran/48820
   5 !
   6 ! Ensure that the value of scalars to assumed-rank arrays is
   7 ! copied back, if and only its pointer address could have changed.
   8 !
   9 program test
  10  implicit none
  11  type t
  12    integer :: aa
  13  end type t
  14
  15  integer, allocatable :: iia
  16  integer, pointer     :: iip
  17
  18  type(t), allocatable :: jja
  19  type(t), pointer     :: jjp
  20
  21  logical :: is_present
  22
  23  is_present = .true.
  24
  25  allocate (iip, jjp)
  26
  27  iia = 7
  28  iip = 7
  29  jja = t(88)
  30  jjp = t(88)
  31
  32  call faa(iia, jja) ! Copy back
  33  if (iia /= 7 .and. jja%aa /= 88) STOP 1
  34  call fai(iia, jja) ! No copy back
  35  if (iia /= 7 .and. jja%aa /= 88) STOP 2
  36
  37  call fpa(iip, jjp) ! Copy back
  38  if (iip /= 7 .and. jjp%aa /= 88) STOP 3
  39  call fpi(iip, jjp) ! No copy back
  40  if (iip /= 7 .and. jjp%aa /= 88) STOP 4
  41
  42  call fnn(iia, jja) ! No copy back
  43  if (iia /= 7 .and. jja%aa /= 88) STOP 5
  44  call fno(iia, jja) ! No copy back
  45  if (iia /= 7 .and. jja%aa /= 88) STOP 6
  46  call fnn(iip, jjp) ! No copy back
  47  if (iip /= 7 .and. jjp%aa /= 88) STOP 7
  48  call fno(iip, jjp) ! No copy back
  49  if (iip /= 7 .and. jjp%aa /= 88) STOP 8
  50
  51  is_present = .false.
  52
  53  call fpa(null(), null()) ! No copy back
  54  call fpi(null(), null()) ! No copy back
  55  call fno(null(), null()) ! No copy back
  56
  57  call fno() ! No copy back
  58
  59 contains
  60
  61   subroutine faa (xx1, yy1)
  62     integer, allocatable :: xx1(..)
  63     type(t), allocatable :: yy1(..)
  64     if (.not. allocated (xx1)) STOP 9
  65     if (.not. allocated (yy1)) STOP 10
  66   end subroutine faa
  67   subroutine fai (xx1, yy1)
  68     integer, allocatable, intent(in) :: xx1(..)
  69     type(t), allocatable, intent(in) :: yy1(..)
  70     if (.not. allocated (xx1)) STOP 11
  71     if (.not. allocated (yy1)) STOP 12
  72   end subroutine fai
  73   subroutine fpa (xx1, yy1)
  74     integer, pointer :: xx1(..)
  75     type(t), pointer :: yy1(..)
  76     if (is_present .neqv. associated (xx1)) STOP 13
  77     if (is_present .neqv. associated (yy1)) STOP 14
  78   end subroutine fpa
  79
  80   subroutine fpi (xx1, yy1)
  81     integer, pointer, intent(in) :: xx1(..)
  82     type(t), pointer, intent(in) :: yy1(..)
  83     if (is_present .neqv. associated (xx1)) STOP 15
  84     if (is_present .neqv. associated (yy1)) STOP 16
  85   end subroutine fpi
  86
  87   subroutine fnn(xx2,yy2)
  88     integer  :: xx2(..)
  89     type(t)  :: yy2(..)
  90   end subroutine fnn
  91
  92   subroutine fno(xx2,yy2)
  93     integer, optional  :: xx2(..)
  94     type(t), optional  :: yy2(..)
  95     if (is_present .neqv. present (xx2)) STOP 17
  96     if (is_present .neqv. present (yy2)) STOP 18
  97   end subroutine fno
  98 end program test
  99
 100 ! We should have exactly one copy back per variable
 101 !
 102 ! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
 103 ! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } }
 104 ! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }
 105 ! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } }