! { dg-do compile }
|
! { dg-do compile }
|
!
|
!
|
! Error checking for the SELECT TYPE statement
|
! Error checking for the SELECT TYPE statement
|
!
|
!
|
! Contributed by Janus Weil
|
! Contributed by Janus Weil
|
|
|
type :: t1
|
type :: t1
|
integer :: i = 42
|
integer :: i = 42
|
class(t1),pointer :: cp
|
class(t1),pointer :: cp
|
end type
|
end type
|
|
|
type, extends(t1) :: t2
|
type, extends(t1) :: t2
|
integer :: j = 99
|
integer :: j = 99
|
end type
|
end type
|
|
|
type :: t3
|
type :: t3
|
real :: r
|
real :: r
|
end type
|
end type
|
|
|
type :: ts
|
type :: ts
|
sequence
|
sequence
|
integer :: k = 5
|
integer :: k = 5
|
end type
|
end type
|
|
|
class(t1), pointer :: a => NULL()
|
class(t1), pointer :: a => NULL()
|
type(t1), target :: b
|
type(t1), target :: b
|
type(t2), target :: c
|
type(t2), target :: c
|
a => b
|
a => b
|
print *, a%i
|
print *, a%i
|
|
|
type is (t1) ! { dg-error "Unexpected TYPE IS statement" }
|
type is (t1) ! { dg-error "Unexpected TYPE IS statement" }
|
|
|
select type (3.5) ! { dg-error "is not a named variable" }
|
select type (3.5) ! { dg-error "is not a named variable" }
|
select type (a%cp) ! { dg-error "is not a named variable" }
|
select type (a%cp) ! { dg-error "is not a named variable" }
|
select type (b) ! { dg-error "Selector shall be polymorphic" }
|
select type (b) ! { dg-error "Selector shall be polymorphic" }
|
|
|
select type (a)
|
select type (a)
|
print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" }
|
print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" }
|
type is (t1)
|
type is (t1)
|
print *,"a is TYPE(t1)"
|
print *,"a is TYPE(t1)"
|
type is (t2)
|
type is (t2)
|
print *,"a is TYPE(t2)"
|
print *,"a is TYPE(t2)"
|
class is (ts) ! { dg-error "must be extensible" }
|
class is (ts) ! { dg-error "must be extensible" }
|
print *,"a is TYPE(ts)"
|
print *,"a is TYPE(ts)"
|
type is (t3) ! { dg-error "must be an extension of" }
|
type is (t3) ! { dg-error "must be an extension of" }
|
print *,"a is TYPE(t3)"
|
print *,"a is TYPE(t3)"
|
type is (t4) ! { dg-error "is not an accessible derived type" }
|
type is (t4) ! { dg-error "is not an accessible derived type" }
|
print *,"a is TYPE(t3)"
|
print *,"a is TYPE(t3)"
|
class is (t1)
|
class is (t1)
|
print *,"a is CLASS(t1)"
|
print *,"a is CLASS(t1)"
|
class is (t2) label ! { dg-error "Syntax error" }
|
class is (t2) label ! { dg-error "Syntax error" }
|
print *,"a is CLASS(t2)"
|
print *,"a is CLASS(t2)"
|
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
print *,"default"
|
print *,"default"
|
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
|
print *,"default2"
|
print *,"default2"
|
end select
|
end select
|
|
|
label: select type (a)
|
label: select type (a)
|
type is (t1) label
|
type is (t1) label
|
print *,"a is TYPE(t1)"
|
print *,"a is TYPE(t1)"
|
type is (t2) ! { dg-error "overlaps with CASE label" }
|
type is (t2) ! { dg-error "overlaps with CASE label" }
|
print *,"a is TYPE(t2)"
|
print *,"a is TYPE(t2)"
|
type is (t2) ! { dg-error "overlaps with CASE label" }
|
type is (t2) ! { dg-error "overlaps with CASE label" }
|
print *,"a is still TYPE(t2)"
|
print *,"a is still TYPE(t2)"
|
class is (t1) labe ! { dg-error "Expected block name" }
|
class is (t1) labe ! { dg-error "Expected block name" }
|
print *,"a is CLASS(t1)"
|
print *,"a is CLASS(t1)"
|
end select label
|
end select label
|
|
|
end
|
end
|
|
|
