Subversion Repositories openrisc

! { dg-do run }

! Test the fix for PR31197 and PR31258 in which the substrings below

! would cause ICEs because the character lengths were never resolved.

!

! Contributed by Joost VandeVondele 

!            and Thomas Koenig 

!

  CHARACTER(LEN=3), DIMENSION(10) :: Z

  CHARACTER(LEN=3), DIMENSION(3,3) :: W

  integer :: ctr = 0

  call test_reshape

  call test_eoshift

  call test_cshift

  call test_spread

  call test_transpose

  call test_pack

  call test_unpack

  call test_pr31197

  if (ctr .ne. 8) call abort

contains

  subroutine test_reshape

    Z(:)="123"

    if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_eoshift

    CHARACTER(LEN=1), DIMENSION(10) :: chk

    chk(1:8) = "5"

    chk(9:10) = " "

    Z(:)="456"

    if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort

    ctr = ctr + 1

  END subroutine

  subroutine test_cshift

    Z(:)="901"

    if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_spread

    Z(:)="789"

    if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_transpose

    W(:, :)="abc"

    if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_pack

    W(:, :)="def"

    if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_unpack

    logical, dimension(5,2) :: mask

    Z(:)="hij"

    mask = .true.

    if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) call abort

    ctr = ctr + 1

  end subroutine

  subroutine test_pr31197

    TYPE data

      CHARACTER(LEN=3) :: A = "xyz"

    END TYPE

    TYPE(data), DIMENSION(10), TARGET :: T

    if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) call abort

    ctr = ctr + 1

  end subroutine

END