xref: /llvm-project-15.0.7/flang/test/Semantics/selecttype01.f90 (revision 142cbd50)

! RUN: %python %S/test_errors.py %s %flang_fc1
! 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)
  !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
  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)
  !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
  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)
    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
    type is(integer)
    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
    type is(real)
    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
    type is(logical)
    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
    type is(character(len=*))
    !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
    type is(complex)
  end select

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

module c1162a
  type pdt(kind,len)
    integer, kind :: kind
    integer, len :: len
  end type
 contains
  subroutine foo(x)
    class(pdt(kind=1,len=:)), allocatable :: x
    select type (x)
    type is (pdt(kind=1, len=*))
    !ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
    type is (pdt(kind=2, len=*))
    !ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
    type is (pdt(kind=*, len=*))
    end select
  end subroutine
end module

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
  select type (unlim_polymorphic)
    type is (INTEGER(4))
    type is (shape)
    !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
    type is (INTEGER(4))
  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