gcc/testsuite/gfortran.dg/class_allocate_25.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! In the course of fixing PR83118, lots of issues came up with class array
   5 ! assignment, where temporaries are generated. This testcase checks that
   6 ! the use of assignment by allocate with source is OK, especially with array
   7 ! constructors using class arrays. While this test did run previously, the
   8 ! temporaries for such arrays were malformed with the class as the type and
   9 ! element lengths of 72 bytes rather than the 4 bytes of the decalred type.
  10 !
  11 ! Contributed by Dominique d'Humieres  <dhumieres.dominique@free.fr>
  12 !
  13 type t1
  14    integer :: i = 5
  15 end type t1
  16 type, extends(t1) :: t2
  17    integer :: j = 6
  18 end type t2
  19
  20 class(t1), allocatable :: a(:), b(:), c(:)
  21 integer :: i
  22
  23 allocate(t2 :: a(3))
  24 allocate(t2 :: b(5))
  25 if (.not.check_t1 (a, [(5, i = 1, 3)], 2)) stop 1
  26
  27 allocate(c, source=[a, b ]) ! F2008, PR 44672
  28 if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 2
  29
  30 deallocate(c)
  31 allocate(c(8), source=[ a, b ])
  32 if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 3
  33
  34 deallocate(c)
  35 c = [t1 :: a, b ] ! F2008, PR 43366
  36 if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 4
  37 deallocate(a, b, c)
  38
  39 contains
  40
  41   logical function check_t1 (arg, array, t)
  42     class(t1) :: arg(:)
  43     integer :: array (:), t
  44     check_t1 = .true.
  45     select type (arg)
  46     type is (t1)
  47       if (any (arg%i .ne. array)) check_t1 = .false.
  48       if (t .eq. 2) check_t1 = .false.
  49     type is (t2)
  50       if (any (arg%i .ne. array)) check_t1 = .false.
  51       if (t .eq. 1) check_t1 = .false.
  52     class default
  53       check_t1 = .false.
  54     end select
  55   end function check_t1
  56
  57 end
  58 ! { dg-final { scan-tree-dump-times "elem_len=72" 0 "original" } }