gcc/testsuite/gfortran.dg/pointer_array_1.f90

   1 ! { dg-do run }
   2 !
   3 ! Check the fix for PR34640 comments 1 and 3.
   4 !
   5 ! This involves passing and returning pointer array components that
   6 ! point to components of arrays of derived types.
   7 !
   8 MODULE test
   9   IMPLICIT NONE
  10   TYPE :: my_type
  11     INTEGER :: value
  12     integer :: tag
  13   END TYPE
  14 CONTAINS
  15   SUBROUTINE get_values(values, switch)
  16     INTEGER, POINTER :: values(:)
  17     integer :: switch
  18     TYPE(my_type), POINTER :: d(:)
  19     allocate (d, source = [my_type(1,101), my_type(2,102)])
  20     if (switch .eq. 1) then
  21       values => d(:)%value
  22       if (any (values .ne. [1,2])) print *, values(2)
  23     else
  24       values => d(:)%tag
  25       if (any (values .ne. [101,102])) call abort
  26     end if
  27   END SUBROUTINE
  28
  29   function return_values(switch) result (values)
  30     INTEGER, POINTER :: values(:)
  31     integer :: switch
  32     TYPE(my_type), POINTER :: d(:)
  33     allocate (d, source = [my_type(1,101), my_type(2,102)])
  34     if (switch .eq. 1) then
  35       values => d(:)%value
  36       if (any (values .ne. [1,2])) call abort
  37     else
  38       values => d(:)%tag
  39       if (any (values([2,1]) .ne. [102,101])) call abort
  40     end if
  41   END function
  42 END MODULE
  43
  44   use test
  45   integer, pointer :: x(:)
  46   type :: your_type
  47     integer, pointer :: x(:)
  48   end type
  49   type(your_type) :: y
  50
  51   call get_values (x, 1)
  52   if (any (x .ne. [1,2])) call abort
  53   call get_values (y%x, 2)
  54   if (any (y%x .ne. [101,102])) call abort
  55
  56   x => return_values (2)
  57   if (any (x .ne. [101,102])) call abort
  58   y%x => return_values (1)
  59   if (any (y%x .ne. [1,2])) call abort
  60 end