gcc/testsuite/gfortran.dg/optional_class_1.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/57445
   4 !
   5 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   6 !
   7 ! Spurious assert was added at revision 192495
   8 !
   9 module m
  10   implicit none
  11   type t
  12     integer :: i
  13   end type t
  14 contains
  15   subroutine opt(xa, xc, xaa, xca)
  16     type(t),  allocatable, intent(out), optional :: xa
  17     class(t), allocatable, intent(out), optional :: xc
  18     type(t),  allocatable, intent(out), optional :: xaa(:)
  19     class(t), allocatable, intent(out), optional :: xca(:)
  20     if (present (xca)) call foo_opt(xca=xca)
  21   end subroutine opt
  22   subroutine foo_opt(xa, xc, xaa, xca)
  23     type(t),  allocatable, intent(out), optional :: xa
  24     class(t), allocatable, intent(out), optional :: xc
  25     type(t),  allocatable, intent(out), optional :: xaa(:)
  26     class(t), allocatable, intent(out), optional :: xca(:)
  27     if (present (xca)) then
  28       if (allocated (xca)) deallocate (xca)
  29       allocate (xca(3), source = [t(9),t(99),t(999)])
  30     end if
  31   end subroutine foo_opt
  32 end module m
  33   use m
  34   class(t), allocatable :: xca(:)
  35   allocate (xca(1), source = t(42))
  36   select type (xca)
  37     type is (t)
  38       if (any (xca%i .ne. [42])) STOP 1
  39   end select
  40   call opt (xca = xca)
  41   select type (xca)
  42     type is (t)
  43       if (any (xca%i .ne. [9,99,999])) STOP 2
  44   end select
  45 end