gcc/testsuite/gfortran.dg/subref_array_pointer_2.f90

   1 ! { dg-do run }
   2 ! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
   3 ! to arrays with subreferences did not work.
   4 !
   5   type :: t
   6     real :: r
   7     integer :: i
   8     character(3) :: chr
   9   end type t
  10
  11   type :: t2
  12     real :: r(2, 2)
  13     integer :: i
  14     character(3) :: chr
  15   end type t2
  16
  17   type :: s
  18     type(t), pointer :: t(:)
  19   end type s
  20
  21   integer, parameter :: sh(2) = (/2,2/)
  22   real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh)
  23   real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh)
  24
  25   type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
  26   character(4), target :: tar2(2) = (/"abcd","efgh"/)
  27   type(s), target :: tar3
  28   character(2), target :: tar4(2) = (/"ab","cd"/)
  29   type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/)
  30
  31   integer, pointer :: ptr(:)
  32   character(2), pointer :: ptr2(:)
  33   real, pointer :: ptr3(:)
  34
  35 !_______________component subreference___________
  36   ptr => tar1%i
  37   ptr = ptr + 1              ! check the scalarizer is OK
  38
  39   if (any (ptr .ne. (/3, 5/))) call abort ()
  40   if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort ()
  41   if (any (tar1%i .ne. (/3, 5/))) call abort ()
  42
  43 ! Make sure that the other components are not touched.
  44   if (any (tar1%r .ne. (/1.0, 3.0/))) call abort ()
  45   if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort ()
  46
  47 ! Check that the pointer is passed correctly as an actual argument.
  48   call foo (ptr)
  49   if (any (tar1%i .ne. (/2, 4/))) call abort ()
  50
  51 ! And that dummy pointers are OK too.
  52   call bar (ptr)
  53   if (any (tar1%i .ne. (/101, 103/))) call abort ()
  54
  55 !_______________substring subreference___________
  56   ptr2 => tar2(:)(2:3)
  57   ptr2 = ptr2(:)(2:2)//"z"   ! again, check the scalarizer
  58
  59   if (any (ptr2 .ne. (/"cz", "gz"/))) call abort ()
  60   if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort ()
  61   if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort ()
  62
  63 !_______________substring component subreference___________
  64   ptr2 => tar1(:)%chr(1:2)
  65   ptr2 = ptr2(:)(2:2)//"q"   ! yet again, check the scalarizer
  66   if (any (ptr2 .ne. (/"bq","fq"/))) call abort ()
  67   if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort ()
  68
  69 !_______________trailing array element subreference___________
  70   ptr3 => tar5%r(1,2)
  71   ptr3 = (/99.0, 999.0/)
  72   if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort ()
  73   if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort ()
  74
  75 !_______________forall assignment___________
  76   ptr2 => tar2(:)(1:2)
  77   forall (i = 1:2) ptr2(i)(1:1) = "z"
  78   if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort ()
  79
  80 !_______________something more complicated___________
  81   tar3%t => tar1
  82   ptr3 => tar3%t%r
  83   ptr3 = cos (ptr3)
  84   if (any (abs(ptr3 - (/cos(1.0_4), cos(3.0_4)/)) >= epsilon(1.0_4))) call abort ()
  85
  86   ptr2 => tar3%t(:)%chr(2:3)
  87   ptr2 = " x"
  88   if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort ()
  89
  90 !_______________check non-subref works still___________
  91   ptr2 => tar4
  92   if (any (ptr2 .ne. (/"ab","cd"/))) call abort ()
  93
  94 contains
  95   subroutine foo (arg)
  96     integer :: arg(:)
  97     arg = arg - 1
  98   end subroutine
  99   subroutine bar (arg)
 100     integer, pointer :: arg(:)
 101     arg = arg + 99
 102   end subroutine
 103 end