gcc/testsuite/gfortran.dg/pr49213.f90

   1 ! { dg-do run }
   2 !
   3 ! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
   4 !
   5 program main
   6   character(2) :: c
   7
   8   type :: S
   9     integer :: n
  10   end type
  11   type(S) :: Sobj
  12
  13   type, extends(S) :: S2
  14     integer :: m
  15   end type
  16   type(S2) :: S2obj
  17
  18   type :: T
  19     class(S), allocatable :: x
  20   end type
  21
  22   type tContainer
  23     class(*), allocatable :: x
  24   end type
  25
  26   type(T) :: Tobj
  27
  28   Sobj = S(1)
  29   Tobj = T(Sobj)
  30
  31   S2obj = S2(1,2)
  32   Tobj = T(S2obj)            ! Failed here
  33   select type (x => Tobj%x)
  34     type is (S2)
  35       if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 1
  36     class default
  37       stop 2
  38   end select
  39
  40   c = "  "
  41   call pass_it (T(Sobj))
  42   if (c .ne. "S ") stop 3
  43   call pass_it (T(S2obj))    ! and here
  44   if (c .ne. "S2") stop 4
  45
  46   call bar
  47
  48 contains
  49
  50   subroutine pass_it (foo)
  51     type(T), intent(in) :: foo
  52     select type (x => foo%x)
  53       type is (S)
  54         c = "S "
  55         if (x%n .ne. 1) stop 5
  56       type is (S2)
  57         c = "S2"
  58         if ((x%n .ne. 1) .or. (x%m .ne. 2)) stop 6
  59       class default
  60         stop 7
  61     end select
  62   end subroutine
  63
  64   subroutine check_it (t, errno)
  65     type(tContainer)  :: t
  66     integer :: errno
  67     select type (x => t%x)
  68       type is (integer)
  69         if (x .ne. 42) stop errno
  70       type is (integer(8))
  71         if (x .ne. 42_8) stop errno
  72       type is (real(8))
  73         if (int(x**2) .ne. 2) stop errno
  74       type is (character(*, kind=1))
  75         if (x .ne. "end of tests") stop errno
  76       type is (character(*, kind=4))
  77         if ((x .ne. 4_"hello!") .and. (x .ne. 4_"goodbye")) stop errno
  78        class default
  79         stop errno
  80     end select
  81   end subroutine
  82
  83   subroutine bar
  84    ! Test from comment #29 extended by Harald Anlauf to check kinds /= default
  85     integer(8), parameter :: i = 0_8
  86     integer :: j = 42
  87     character(7,kind=4) :: chr4 = 4_"goodbye"
  88     type(tContainer) :: cont
  89
  90     cont%x = j
  91     call check_it (cont, 8)
  92
  93     cont = tContainer(i+42_8)
  94     call check_it (cont, 9)
  95
  96     cont = tContainer(sqrt (2.0_8))
  97     call check_it (cont, 10)
  98
  99     cont = tContainer(4_"hello!")
 100     call check_it (cont, 11)
 101
 102     cont = tContainer(chr4)
 103     call check_it (cont, 12)
 104
 105     cont = tContainer("end of tests")
 106     call check_it (cont, 13)
 107
 108   end subroutine bar
 109 end program