gcc/testsuite/gfortran.dg/class_48.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/51972
   4 !
   5 ! Check whether DT assignment with polymorphic components works.
   6 !
   7
   8 subroutine test1 ()
   9   type t
  10     integer :: x
  11   end type t
  12
  13   type t2
  14     class(t), allocatable :: a
  15   end type t2
  16
  17   type(t2) :: one, two
  18
  19   one = two
  20   if (allocated (one%a)) call abort ()
  21
  22   allocate (two%a)
  23   two%a%x = 7890
  24   one = two
  25   if (one%a%x /= 7890) call abort ()
  26
  27   deallocate (two%a)
  28   one = two
  29   if (allocated (one%a)) call abort ()
  30 end subroutine test1
  31
  32 subroutine test2 ()
  33   type t
  34     integer, allocatable :: x(:)
  35   end type t
  36
  37   type t2
  38     class(t), allocatable :: a
  39   end type t2
  40
  41   type(t2) :: one, two
  42
  43   one = two
  44   if (allocated (one%a)) call abort ()
  45
  46   allocate (two%a)
  47   one = two
  48   if (.not.allocated (one%a)) call abort ()
  49   if (allocated (one%a%x)) call abort ()
  50
  51   allocate (two%a%x(2))
  52   two%a%x(:) = 7890
  53   one = two
  54   if (any (one%a%x /= 7890)) call abort ()
  55
  56   deallocate (two%a)
  57   one = two
  58   if (allocated (one%a)) call abort ()
  59 end subroutine test2
  60
  61
  62 subroutine test3 ()
  63   type t
  64     integer :: x
  65   end type t
  66
  67   type t2
  68     class(t), allocatable :: a(:)
  69   end type t2
  70
  71   type(t2) :: one, two
  72
  73   one = two
  74   if (allocated (one%a)) call abort ()
  75
  76   allocate (two%a(2), source=[t(4), t(6)])
  77   one = two
  78   if (.not.allocated (one%a)) call abort ()
  79 ! FIXME: Check value
  80
  81   deallocate (two%a)
  82   one = two
  83   if (allocated (one%a)) call abort ()
  84 end subroutine test3
  85
  86 subroutine test4 ()
  87   type t
  88     integer, allocatable :: x(:)
  89   end type t
  90
  91   type t2
  92     class(t), allocatable :: a(:)
  93   end type t2
  94
  95   type(t2) :: one, two
  96
  97   one = two
  98   if (allocated (one%a)) call abort ()
  99
 100 !  allocate (two%a(2)) ! ICE: SEGFAULT
 101 !  one = two
 102 !  if (.not. allocated (one%a)) call abort ()
 103 end subroutine test4
 104
 105
 106 call test1 ()
 107 call test2 ()
 108 call test3 ()
 109 call test4 ()
 110 end