gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03

   1 ! { dg-do run }
   2 ! { dg-options "-Wreturn-type" }
   3 !
   4 ! Check that pr58586 is fixed now.
   5 ! Based on a contribution by Vladimir Fuka
   6 ! Contibuted by Andre Vehreschild
   7
   8 module test_pr58586_mod
   9   implicit none
  10
  11   type :: a
  12   end type
  13
  14   type :: c
  15      type(a), allocatable :: a
  16   end type
  17
  18   type :: d
  19   contains
  20      procedure :: init => d_init
  21   end type
  22
  23   type, extends(d) :: e
  24   contains
  25      procedure :: init => e_init
  26   end type
  27
  28   type :: b
  29      integer, allocatable :: a
  30   end type
  31
  32   type t
  33     integer :: i = 5
  34   end type
  35
  36 contains
  37
  38   subroutine add (d)
  39     type(b), value :: d
  40   end subroutine
  41
  42   subroutine add_c (d)
  43     type(c), value :: d
  44   end subroutine
  45
  46   subroutine add_class_c (d)
  47     class(c), value :: d
  48   end subroutine
  49
  50   subroutine add_t (d)
  51     type(t), value :: d
  52   end subroutine
  53
  54   type(c) function c_init() ! { dg-warning "not set" }
  55   end function
  56
  57   class(c) function c_init2() ! { dg-warning "not set" }
  58     allocatable :: c_init2
  59   end function
  60
  61   type(c) function d_init(this) ! { dg-warning "not set" }
  62     class(d) :: this
  63   end function
  64
  65   type(c) function e_init(this)
  66     class(e) :: this
  67     allocate (e_init%a)
  68   end function
  69
  70   type(t) function t_init() ! { dg-warning "not set" }
  71     allocatable :: t_init
  72   end function
  73
  74   type(t) function static_t_init() ! { dg-warning "not set" }
  75   end function
  76 end module test_pr58586_mod
  77
  78 program test_pr58586
  79   use test_pr58586_mod
  80
  81   class(d), allocatable :: od
  82   class(e), allocatable :: oe
  83   type(t), allocatable :: temp
  84
  85   ! These two are merely to check, if compilation works
  86   call add(b())
  87   call add(b(null()))
  88
  89   ! This needs to execute, to see whether the segfault at runtime is resolved
  90   call add_c(c_init())
  91   call add_class_c(c_init2())
  92
  93   call add_t(static_t_init())
  94   ! temp = t_init() ! <-- This derefs a null-pointer currently
  95   ! Filed as pr66775
  96   if (allocated (temp)) call abort()
  97
  98   allocate(od)
  99   call add_c(od%init())
 100   deallocate(od)
 101   allocate(oe)
 102   call add_c(oe%init())
 103   deallocate(oe)
 104 end program
 105