gcc/testsuite/gfortran.dg/intent_out_17.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/92178
   4 ! Contributed by Tobias Burnus
   5
   6 program foo
   7   implicit none (type, external)
   8
   9   type t
  10   end type t
  11
  12   type, extends(t) :: t2
  13   end type t2
  14
  15   type(t2) :: x2
  16   class(t), allocatable :: aa
  17
  18   call check_intentout_false(allocated(aa), aa, &
  19                              allocated(aa))
  20   if (allocated(aa)) stop 1
  21
  22   allocate(t2 :: aa)
  23   if (.not.allocated(aa)) stop 2
  24   if (.not.same_type_as(aa, x2)) stop 3
  25   call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, &
  26                             allocated(aa), (same_type_as(aa, x2)))
  27   if (allocated(aa)) stop 4
  28
  29 contains
  30   subroutine check_intentout_false(alloc1, yy, alloc2)
  31     logical, value :: alloc1, alloc2
  32     class(t), allocatable, intent(out) :: yy
  33     if (allocated(yy)) stop 11
  34     if (alloc1) stop 12
  35     if (alloc2) stop 13
  36   end subroutine check_intentout_false
  37   subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2)
  38     logical, value :: alloc1, alloc2, same1, same2
  39     class(t), allocatable, intent(out) :: zz
  40     if (allocated(zz)) stop 21
  41     if (.not.alloc1) stop 22
  42     if (.not.alloc2) stop 23
  43     if (.not.same1) stop 24
  44     if (.not.same2) stop 25
  45   end subroutine check_intentout_true
  46 end program