1! { dg-do run } 2! 3! executing SELECT TYPE statements with CLASS IS blocks 4! 5! Contributed by Janus Weil <janus@gcc.gnu.org> 6 7 implicit none 8 9 type :: t1 10 integer :: i 11 end type t1 12 13 type, extends(t1) :: t2 14 integer :: j 15 end type t2 16 17 type, extends(t2) :: t3 18 real :: r 19 end type 20 21 class(t1), pointer :: cp 22 type(t1), target :: a 23 type(t2), target :: b 24 type(t3), target :: c 25 integer :: i 26 27 cp => c 28 i = 0 29 select type (cp) 30 type is (t1) 31 i = 1 32 type is (t2) 33 i = 2 34 class is (t1) 35 i = 3 36 class default 37 i = 4 38 end select 39 print *,i 40 if (i /= 3) call abort() 41 42 cp => a 43 select type (cp) 44 type is (t1) 45 i = 1 46 type is (t2) 47 i = 2 48 class is (t1) 49 i = 3 50 end select 51 print *,i 52 if (i /= 1) call abort() 53 54 cp => b 55 select type (cp) 56 type is (t1) 57 i = 1 58 class is (t3) 59 i = 3 60 class is (t2) 61 i = 4 62 class is (t1) 63 i = 5 64 end select 65 print *,i 66 if (i /= 4) call abort() 67 68 cp => b 69 select type (cp) 70 type is (t1) 71 i = 1 72 class is (t1) 73 i = 5 74 class is (t2) 75 i = 4 76 class is (t3) 77 i = 3 78 end select 79 print *,i 80 if (i /= 4) call abort() 81 82 cp => a 83 select type (cp) 84 type is (t2) 85 i = 1 86 class is (t2) 87 i = 2 88 class default 89 i = 3 90 class is (t3) 91 i = 4 92 type is (t3) 93 i = 5 94 end select 95 print *,i 96 if (i /= 3) call abort() 97 98end 99