test/Semantics/selecttype01.f90

! RUN: %S/test_errors.sh %s %t %f18
! Test for checking select type constraints,
module m1
  use ISO_C_BINDING
  type shape
    integer :: color
    logical :: filled
    integer :: x
    integer :: y
  end type shape

  type, extends(shape) :: rectangle
    integer :: length
    integer :: width
  end type rectangle

  type, extends(rectangle) :: square
  end type square

  type, extends(square) :: extsquare
  end type

  type :: unrelated
    logical :: some_logical
  end type

  type withSequence
    SEQUENCE
    integer :: x
  end type

  type, BIND(C) :: withBind
    INTEGER(c_int) ::int_in_c
  end type

  TYPE(shape), TARGET :: shape_obj
  TYPE(rectangle), TARGET :: rect_obj
  TYPE(square), TARGET :: squr_obj
  !define polymorphic objects
  class(*), pointer :: unlim_polymorphic
  class(shape), pointer :: shape_lim_polymorphic
end
module m
  type :: t(n)
    integer, len :: n
  end type
contains
  subroutine CheckC1160( a )
    class(*), intent(in) :: a
    select type ( a )
      !ERROR: The type specification statement must have LEN type parameter as assumed
      type is ( character(len=10) ) !<-- assumed length-type
      ! OK
      type is ( character(len=*) )
      !ERROR: The type specification statement must have LEN type parameter as assumed
      type is ( t(n=10) )
      ! OK
      type is ( t(n=*) )   !<-- assumed length-type
      !ERROR: Derived type 'character' not found
      class is ( character(len=10) ) !<-- assumed length-type
    end select
  end subroutine

  subroutine s()
    type derived(param)
      integer, len :: param
      class(*), allocatable :: x
    end type
    TYPE(derived(10)) :: a
    select type (ax => a%x)
      class is (derived(param=*))
        print *, "hello"
    end select
  end subroutine s
end module

subroutine CheckC1157
  use m1
  integer, parameter :: const_var=10
  !ERROR: Selector is not a named variable: 'associate-name =>' is required
  select type(10)
  end select
  !ERROR: Selector is not a named variable: 'associate-name =>' is required
  select type(const_var)
  end select
  !ERROR: Selector is not a named variable: 'associate-name =>' is required
  select type (4.999)
  end select
  !ERROR: Selector is not a named variable: 'associate-name =>' is required
  select type (shape_obj%x)
  end select
end subroutine

!CheckPloymorphicSelectorType
subroutine CheckC1159a
  integer :: int_variable
  real :: real_variable
  complex :: complex_var = cmplx(3.0, 4.0)
  logical :: log_variable
  character (len=10) :: char_variable = "OM"
  !ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic
  select type (int_variable)
  end select
  !ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic
  select type (real_variable)
  end select
  !ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic
  select type(complex_var)
  end select
  !ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic
  select type(logical_variable)
  end select
  !ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic
  select type(char_variable)
  end select
end

subroutine CheckC1159b
  integer :: x
  !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
  select type (a => x)
  type is (integer)
    print *,'integer ',a
  end select
end

subroutine CheckC1159c
  !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
  select type (a => x)
  type is (integer)
    print *,'integer ',a
  end select
end

subroutine s(arg)
  class(*) :: arg
    select type (arg)
        type is (integer)
    end select
end

subroutine CheckC1161
  use m1
  shape_lim_polymorphic => rect_obj
  select type(shape_lim_polymorphic)
    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
    type is (withSequence)
    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
    type is (withBind)
  end select
end

subroutine CheckC1162
  use m1
  class(rectangle), pointer :: rectangle_polymorphic
  !not unlimited polymorphic objects
  select type (rectangle_polymorphic)
    !ERROR: Type specification 'shape' must be an extension of TYPE 'rectangle'
    type is (shape)
    !ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
    type is (unrelated)
    !all are ok
    type is (square)
    type is (extsquare)
    !Handle same types
    type is (rectangle)
  end select

  !Unlimited polymorphic objects are allowed.
  unlim_polymorphic => rect_obj
  select type (unlim_polymorphic)
    type is (shape)
    type is (unrelated)
  end select
end

subroutine CheckC1163
  use m1
  !assign dynamically
  shape_lim_polymorphic => rect_obj
  unlim_polymorphic => shape_obj
  select type (shape_lim_polymorphic)
    type is (shape)
    !ERROR: Type specification 'shape' conflicts with previous type specification
    type is (shape)
    class is (square)
    !ERROR: Type specification 'square' conflicts with previous type specification
    class is (square)
  end select
end

subroutine CheckC1164
  use m1
  shape_lim_polymorphic => rect_obj
  unlim_polymorphic => shape_obj
  select type (shape_lim_polymorphic)
    CLASS DEFAULT
    !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
    CLASS DEFAULT
    TYPE IS (shape)
    TYPE IS (rectangle)
    !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
    CLASS DEFAULT
  end select

  !Saving computation if some error in guard by not computing RepeatingCases
  select type (shape_lim_polymorphic)
    CLASS DEFAULT
    CLASS DEFAULT
    !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
    TYPE IS(withSequence)
  end select
end subroutine

subroutine WorkingPolymorphism
  use m1
  !assign dynamically
  shape_lim_polymorphic => rect_obj
  unlim_polymorphic => shape_obj
  select type (shape_lim_polymorphic)
    type is  (shape)
      print *, "hello shape"
    type is  (rectangle)
      print *, "hello rect"
    type is  (square)
      print *, "hello square"
    CLASS DEFAULT
      print *, "default"
  end select
  print *, "unlim polymorphism"
  select type (unlim_polymorphic)
    type is  (shape)
      print *, "hello shape"
    type is  (rectangle)
      print *, "hello rect"
    type is  (square)
      print *, "hello square"
    CLASS DEFAULT
      print *, "default"
  end select
end