gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03

   1 ! { dg-do run }
   2 ! { dg-additional-options "-fdump-tree-dse-details" }
   3 !
   4 ! Check that pointer assignments allowed by F2003:C717
   5 ! work and check null initialization of CLASS(*) pointers.
   6 !
   7 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
   8 !
   9 program main
  10   interface
  11     subroutine foo_bc(z)
  12       class(*), pointer, intent(in) :: z
  13     end subroutine foo_bc
  14     subroutine foo_sq(z)
  15       class(*), pointer, intent(in) :: z
  16     end subroutine foo_sq
  17   end interface
  18   type, bind(c) :: bc
  19     integer :: i
  20   end type bc
  21   type sq
  22     sequence
  23     integer :: k
  24   end type sq
  25   type(bc), target :: w
  26   type(sq), target :: x
  27   class(*), pointer :: y, z
  28   w%i = 23
  29   y => w
  30   z => y ! unlimited => unlimited allowed
  31   call foo_bc(z)
  32   x%k = 42
  33   y => x
  34   z => y ! unlimited => unlimited allowed
  35   call foo_sq(z)
  36   call bar
  37 contains
  38   subroutine bar
  39     type t
  40     end type t
  41     type(t), pointer :: x
  42     class(*), pointer :: ptr1 => null() ! pointer initialization
  43     if (same_type_as (ptr1, x) .neqv. .FALSE.) STOP 1
  44   end subroutine bar
  45
  46 end program main
  47
  48 subroutine foo_bc(tgt)
  49   use iso_c_binding
  50   class(*), pointer, intent(in) :: tgt
  51   type, bind(c) :: bc
  52     integer (c_int) :: i
  53   end type bc
  54   type(bc), pointer :: ptr1
  55   ptr1 => tgt ! bind(c) => unlimited allowed
  56   if (ptr1%i .ne. 23) STOP 2
  57 end subroutine foo_bc
  58
  59 subroutine foo_sq(tgt)
  60   class(*), pointer, intent(in) :: tgt
  61   type sq
  62     sequence
  63     integer :: k
  64   end type sq
  65   type(sq), pointer :: ptr2
  66   ptr2 => tgt ! sequence type => unlimited allowed
  67   if (ptr2%k .ne. 42) STOP 3
  68 end subroutine foo_sq
  69
  70 ! PR fortran/103662
  71 ! We used to produce multiple independant types for the unlimited polymorphic
  72 ! descriptors (types for class(*)) which caused stores to them to be seen as
  73 ! useless.
  74 ! { dg-final { scan-tree-dump-not "Deleted dead store: z._data = &w" "dse1" { target __OPTIMIZE__ } } }
  75 ! { dg-final { scan-tree-dump-not "Deleted dead store: z._data = &x" "dse1" { target __OPTIMIZE__ } } }