gcc/testsuite/gfortran.dg/subref_array_pointer_1.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   call pr29396
   6   call pr29606
   7   call pr30625
   8   call pr30871
   9 contains
  10   subroutine pr29396
  11 ! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
  12     CHARACTER(LEN=2), DIMENSION(:), POINTER :: a
  13     CHARACTER(LEN=4), DIMENSION(3), TARGET :: b
  14     b=(/"bbbb","bbbb","bbbb"/)
  15     a=>b(:)(2:3)
  16     a="aa"
  17     IF (ANY(b.NE.(/"baab","baab","baab"/))) CALL ABORT()
  18   END subroutine
  19
  20   subroutine pr29606
  21 ! Contributed by Daniel Franke <franke.daniel@gmail.com>
  22     TYPE foo
  23       INTEGER :: value
  24     END TYPE
  25     TYPE foo_array
  26       TYPE(foo), DIMENSION(:), POINTER :: array
  27     END TYPE
  28     TYPE(foo_array)                :: array_holder
  29     INTEGER, DIMENSION(:), POINTER :: array_ptr
  30     ALLOCATE( array_holder%array(3) )
  31     array_holder%array = (/ foo(1), foo(2), foo(3) /)
  32     array_ptr => array_holder%array%value
  33     if (any (array_ptr .ne. (/1,2,3/))) call abort ()
  34   END subroutine
  35
  36   subroutine pr30625
  37 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
  38     type :: a
  39       real :: r = 3.14159
  40       integer :: i = 42
  41     end type a
  42     type(a), target :: dt(2)
  43     integer, pointer :: ip(:)
  44     ip => dt%i
  45     if (any (ip .ne. 42)) call abort ()
  46   end subroutine
  47
  48   subroutine pr30871
  49 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
  50     TYPE data
  51       CHARACTER(LEN=3) :: A
  52     END TYPE
  53     TYPE(data), DIMENSION(10), TARGET :: Z
  54     CHARACTER(LEN=1), DIMENSION(:), POINTER :: ptr
  55     Z(:)%A="123"
  56     ptr=>Z(:)%A(2:2)
  57     if (any (ptr .ne. "2")) call abort ()
  58   END subroutine
  59 end