TheRock/compiler/amd-llvm/flang/test/Semantics/case01.f90

! RUN: %python %S/test_errors.py %s %flang_fc1
! Test SELECT CASE Constraints: C1145, C1146, C1147, C1148, C1149
program selectCaseProg
   implicit none
   ! local variable declaration
   character :: grade1 = 'B'
   integer :: grade2 = 3
   logical :: grade3 = .false.
   real :: grade4 = 2.0
   character (len = 10) :: name = 'test'
   logical, parameter :: grade5 = .false.
   CHARACTER(KIND=1), parameter :: ASCII_parm1 = 'a', ASCII_parm2='b'
   CHARACTER(KIND=2), parameter :: UCS16_parm = 'c'
   CHARACTER(KIND=4), parameter :: UCS32_parm ='d'
   type scores
     integer :: val
   end type
   type (scores) :: score = scores(25)
   type (scores), parameter :: score_val = scores(50)

  ! Valid Cases
   select case (grade1)
      case ('A')
      case ('B')
      case ('C')
      case default
   end select

   select case (grade2)
      case (1)
      case (2)
      case (3)
      case default
   end select

   select case (grade3)
      case (.true.)
      case (.false.)
   end select

   select case (name)
      case default
      case ('now')
      case ('test')
   end select

  ! C1145
  !ERROR: SELECT CASE expression must be integer, logical, or character
  select case (grade4)
     case (1.0)
     case (2.0)
     case (3.0)
     case default
  end select

  !ERROR: SELECT CASE expression must be integer, logical, or character
  select case (score)
     case (score_val)
     case (scores(100))
  end select

  ! C1146
  select case (grade3)
     case default
     case (.true.)
     !ERROR: CASE DEFAULT conflicts with previous cases
     case default
  end select

  ! C1147
  select case (grade2)
     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
     case (:'Z')
     case default
   end select

  select case (grade1)
     !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
     case (:1)
     case default
   end select

  select case (grade3)
     case default
     case (.true.)
     !ERROR: CASE value has type 'INTEGER(4)' which is not compatible with the SELECT CASE expression's type 'LOGICAL(4)'
     case (3)
  end select

  select case (grade2)
     case default
     case (2 :)
     !ERROR: CASE value has type 'LOGICAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
     case (.true. :)
     !ERROR: CASE value has type 'REAL(4)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
     case (1.0)
     !ERROR: CASE value has type 'CHARACTER(KIND=1,LEN=3_8)' which is not compatible with the SELECT CASE expression's type 'INTEGER(4)'
     case ('wow')
  end select

  select case (ASCII_parm1)
     case (ASCII_parm2)
     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
     case (UCS32_parm)
     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=1_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
     case (UCS16_parm)
     !ERROR: CASE value has type 'CHARACTER(KIND=4,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
     case (4_"ucs-32")
     !ERROR: CASE value has type 'CHARACTER(KIND=2,LEN=6_8)' which is not compatible with the SELECT CASE expression's type 'CHARACTER(KIND=1,LEN=1_8)'
     case (2_"ucs-16")
     case default
   end select

  ! C1148
  select case (grade3)
     case default
     !ERROR: CASE range is not allowed for LOGICAL
     case (.true. :)
  end select

  ! C1149
  select case (grade3)
    case (.true.)
    case (.false.)
     !ERROR: CASE (.true._1) conflicts with previous cases
     case (.true.)
    !ERROR: CASE (.false._1) conflicts with previous cases
     case (grade5)
  end select

  select case (grade2)
     !WARNING: CASE has lower bound greater than upper bound [-Wempty-case]
     case (51:50)
     case (100:)
     case (:30)
     case (40)
     case (90)
     case (91:99)
     !ERROR: CASE (81_4:90_4) conflicts with previous cases
     case (81:90)
     !ERROR: CASE (:80_4) conflicts with previous cases
     case (:80)
     !ERROR: CASE (200_4) conflicts with previous cases
     case (200)
     case default
  end select

  select case (name)
     case ('hello')
     case ('hey')
     !ERROR: CASE (:"hh") conflicts with previous cases
     case (:'hh')
     !ERROR: CASE (:"hd") conflicts with previous cases
     case (:'hd')
     case ( 'hu':)
     case ('hi':'ho')
     !ERROR: CASE ("hj") conflicts with previous cases
     case ('hj')
     !ERROR: CASE ("ha") conflicts with previous cases
     case ('ha')
     !ERROR: CASE ("hz") conflicts with previous cases
     case ('hz')
     case default
   end select

end program

subroutine test_overlap
  integer :: i
  !OK: these cases do not overlap
  select case(i)
    case(0:)
    case(:-1)
  end select
  select case(i)
    case(-1:)
    !ERROR: CASE (:0_4) conflicts with previous cases
    case(:0)
  end select
end

subroutine test_overflow
  integer :: j
  select case(1_1)
  case (127)
  !WARNING: CASE value (128_4) overflows type (INTEGER(1)) of SELECT CASE expression [-Wcase-overflow]
  case (128)
  !WARNING: CASE value (129_4) overflows type (INTEGER(1)) of SELECT CASE expression [-Wcase-overflow]
  !WARNING: CASE value (130_4) overflows type (INTEGER(1)) of SELECT CASE expression [-Wcase-overflow]
  case (129:130)
  !WARNING: CASE value (-130_4) overflows type (INTEGER(1)) of SELECT CASE expression [-Wcase-overflow]
  !WARNING: CASE value (-129_4) overflows type (INTEGER(1)) of SELECT CASE expression [-Wcase-overflow]
  case (-130:-129)
  case (-128)
  !ERROR: Must be a scalar value, but is a rank-1 array
  case ([1, 2])
  !ERROR: Must be a constant value
  case (j)
  case default
  end select
end