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 type(t1), target :: b 27 type(t2), target :: c 28 a => b 29 print *, a%i 30 31 type is (t1) ! { dg-error "Unexpected TYPE IS statement" } 32 33 select type (3.5) ! { dg-error "is not a named variable" } 34 select type (a%cp) ! { dg-error "is not a named variable" } 35 select type (b) ! { dg-error "Selector shall be polymorphic" } 36 end select 37 38 select type (a) 39 print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" } 40 type is (t1) 41 print *,"a is TYPE(t1)" 42 type is (t2) 43 print *,"a is TYPE(t2)" 44 class is (ts) ! { dg-error "must be extensible" } 45 print *,"a is TYPE(ts)" 46 type is (t3) ! { dg-error "must be an extension of" } 47 print *,"a is TYPE(t3)" 48 type is (t4) ! { dg-error "error in TYPE IS specification" } 49 print *,"a is TYPE(t3)" 50 class is (t1) 51 print *,"a is CLASS(t1)" 52 class is (t2) label ! { dg-error "Syntax error" } 53 print *,"a is CLASS(t2)" 54 class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } 55 print *,"default" 56 class default ! { dg-error "cannot be followed by a second DEFAULT CASE" } 57 print *,"default2" 58 end select 59 60label: select type (a) 61 type is (t1) label 62 print *,"a is TYPE(t1)" 63 type is (t2) ! { dg-error "overlaps with CASE label" } 64 print *,"a is TYPE(t2)" 65 type is (t2) ! { dg-error "overlaps with CASE label" } 66 print *,"a is still TYPE(t2)" 67 class is (t1) labe ! { dg-error "Expected block name" } 68 print *,"a is CLASS(t1)" 69 end select label 70 71end 72