char_length_8.f90

来自「用于进行gcc测试」· F90 代码 · 共 70 行

! { 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 <[e-mail]> 
!            and Thomas Koenig <[e-mail]>
!
  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