gcc/testsuite/gfortran.dg/class_array_16.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 module m
   5   implicit none
   6   type t
   7   end type t
   8
   9   type, extends(t) :: t2
  10   end type t2
  11
  12   type(t) :: var_t
  13   type(t2) :: var_t2
  14 contains
  15   subroutine sub(x)
  16      class(t), allocatable, intent(out) :: x(:)
  17
  18      if (allocated (x)) call abort()
  19      if (.not. same_type_as(x, var_t)) call abort()
  20
  21      allocate (t2 :: x(5))
  22   end subroutine sub
  23
  24   subroutine sub2(x)
  25      class(t), allocatable, OPTIONAL, intent(out) :: x(:)
  26
  27      if (.not. present(x)) return
  28      if (allocated (x)) call abort()
  29      if (.not. same_type_as(x, var_t)) call abort()
  30
  31      allocate (t2 :: x(5))
  32   end subroutine sub2
  33 end module m
  34
  35 use m
  36 implicit none
  37 class(t), save, allocatable :: y(:)
  38
  39 if (allocated (y)) call abort()
  40 if (.not. same_type_as(y,var_t)) call abort()
  41
  42 call sub(y)
  43 if (.not.allocated(y)) call abort()
  44 if (.not. same_type_as(y, var_t2)) call abort()
  45 if (size (y) /= 5) call abort()
  46
  47 call sub(y)
  48 if (.not.allocated(y)) call abort()
  49 if (.not. same_type_as(y, var_t2)) call abort()
  50 if (size (y) /= 5) call abort()
  51
  52 deallocate (y)
  53 if (allocated (y)) call abort()
  54 if (.not. same_type_as(y,var_t)) call abort()
  55
  56 call sub2()
  57
  58 call sub2(y)
  59 if (.not.allocated(y)) call abort()
  60 if (.not. same_type_as(y, var_t2)) call abort()
  61 if (size (y) /= 5) call abort()
  62
  63 call sub2(y)
  64 if (.not.allocated(y)) call abort()
  65 if (.not. same_type_as(y, var_t2)) call abort()
  66 if (size (y) /= 5) call abort()
  67 end
  68
  69 ! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
  70 ! { dg-final { scan-tree-dump-times "finally" 0 "original" } }