gcc/testsuite/gfortran.dg/unlimited_polymorphic_3.f03

   1 ! { dg-do run }
   2 !
   3 ! Check that pointer assignments allowed by F2003:C717
   4 ! work and check null initialization of CLASS(*) pointers.
   5 !
   6 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
   7 !
   8 program main
   9   interface
  10     subroutine foo(z)
  11       class(*), pointer, intent(in) :: z
  12     end subroutine foo
  13   end interface
  14   type sq
  15     sequence
  16     integer :: i
  17   end type sq
  18   type(sq), target :: x
  19   class(*), pointer :: y, z
  20   x%i = 42
  21   y => x
  22   z => y ! unlimited => unlimited allowed
  23   call foo (z)
  24   call bar
  25 contains
  26   subroutine bar
  27     type t
  28     end type t
  29     type(t), pointer :: x
  30     class(*), pointer :: ptr1 => null() ! pointer initialization
  31     if (same_type_as (ptr1, x) .neqv. .FALSE.) STOP 1
  32   end subroutine bar
  33
  34 end program main
  35
  36
  37 subroutine foo(tgt)
  38   use iso_c_binding
  39   class(*), pointer, intent(in) :: tgt
  40   type, bind(c) :: s
  41     integer (c_int) :: k
  42   end type s
  43   type t
  44     sequence
  45     integer :: k
  46   end type t
  47   type(s), pointer :: ptr1
  48   type(t), pointer :: ptr2
  49   ptr1 => tgt ! bind(c) => unlimited allowed
  50   if (ptr1%k .ne. 42) STOP 2
  51   ptr2 => tgt ! sequence type => unlimited allowed
  52   if (ptr2%k .ne. 42) STOP 3
  53 end subroutine foo