gcc/testsuite/gfortran.dg/class_array_14.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/54618
   4 !
   5 ! Check whether default initialization works with INTENT(OUT)
   6 ! and ALLOCATABLE and no segfault occurs with OPTIONAL.
   7 !
   8
   9 subroutine test1()
  10   type typ1
  11     integer :: i = 6
  12   end type typ1
  13
  14   type(typ1) :: x
  15
  16   x%i = 77
  17   call f(x)
  18   if (x%i /= 6) STOP 1
  19   call f()
  20 contains
  21   subroutine f(y1)
  22     class(typ1), intent(out), optional :: y1
  23   end subroutine f
  24 end subroutine test1
  25
  26 subroutine test2()
  27   type mytype
  28   end type mytype
  29   type, extends(mytype):: mytype2
  30   end type mytype2
  31
  32   class(mytype), allocatable :: x,y
  33   allocate (mytype2 :: x)
  34   call g(x)
  35   if (allocated (x) .or. .not. same_type_as (x,y)) STOP 2
  36
  37   allocate (mytype2 :: x)
  38   call h(x)
  39   if (allocated (x) .or. .not. same_type_as (x,y)) STOP 3
  40
  41   call h()
  42 contains
  43   subroutine g(y2)
  44     class(mytype), intent(out), allocatable :: y2
  45   end subroutine g
  46   subroutine h(y3)
  47     class(mytype), optional, intent(out), allocatable :: y3
  48   end subroutine h
  49 end subroutine test2
  50
  51 call test1()
  52 call test2()
  53 end