1! { dg-do compile } 2! 3! Error checking for the SELECT TYPE statement 4! 5! Contributed by Janus Weil <janus@gcc.gnu.org> 6 7 type :: t1 8 integer :: i = 42 9 class(t1),pointer :: cp 10 end type 11 12 type, extends(t1) :: t2 13 integer :: j = 99 14 end type 15 16 type :: t3 17 real :: r 18 end type 19 20 type :: ts 21 sequence 22 integer :: k = 5 23 end type 24 25 class(t1), pointer :: a => NULL() 26 class(t1), allocatable, dimension(:) :: ca 27 type(t1), target :: b 28 type(t2), target :: c 29 a => b 30 print *, a%i 31 32 type is (t1) ! { dg-error "Unexpected TYPE IS statement" } 33 34 select type (3.5) ! { dg-error "is not a named variable" } 35 select type (a%cp) ! { dg-error "is not a named variable" } 36 select type (ca(1))! { dg-error "is not a named variable" } 37 select type (b) ! { dg-error "Selector shall be polymorphic" } 38 end select 39 40 select type (a) 41 print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" } 42 type is (t1) 43 print *,"a is TYPE(t1)" 44 type is (t2) 45 print *,"a is TYPE(t2)" 46 class is (ts) ! { dg-error "must be extensible" } 47 print *,"a is TYPE(ts)" 48 type is (t3) ! { dg-error "must be an extension of" } 49 print *,"a is TYPE(t3)" 50 type is (t4) ! { dg-error "error in TYPE IS specification" } 51 print *,"a is TYPE(t3)" 52 class is (t1) 53 print *,"a is CLASS(t1)" 54 class is (t2) label ! { dg-error "Syntax error" } 55 print *,"a is CLASS(t2)" 56 class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } 57 print *,"default" 58 class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } 59 print *,"default2" 60 end select 61 62label: select type (a) 63 type is (t1) label 64 print *,"a is TYPE(t1)" 65 type is (t2) ! { dg-error "overlaps with TYPE IS" } 66 print *,"a is TYPE(t2)" 67 type is (t2) ! { dg-error "overlaps with TYPE IS" } 68 print *,"a is still TYPE(t2)" 69 class is (t1) labe ! { dg-error "Expected block name" } 70 print *,"a is CLASS(t1)" 71 end select label 72 73end 74