Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line source
! { dg-do run } ! ! Testing fix for PR fortran/60255 ! ! Author: Andre Vehreschild <vehre@gmx.de> ! MODULE m contains subroutine bar (arg, res) class(*) :: arg character(100) :: res select type (w => arg) type is (character(*)) write (res, '(I2)') len(w) end select end subroutine END MODULE program test use m; implicit none character(LEN=:), allocatable, target :: S character(LEN=100) :: res class(*), pointer :: ucp, ucp2 call sub1 ("long test string", 16) call sub2 () S = "test" ucp => S call sub3 (ucp) allocate (ucp2, source=ucp) call sub3 (ucp2) call sub4 (S, 4) call sub4 ("This is a longer string.", 24) call bar (S, res) if (trim (res) .NE. " 4") call abort () call bar(ucp, res) if (trim (res) .NE. " 4") call abort () contains subroutine sub1(dcl, ilen) character(len=*), target :: dcl integer(4) :: ilen character(len=:), allocatable :: hlp class(*), pointer :: ucp ucp => dcl select type (ucp) type is (character(len=*)) if (len(dcl) .NE. ilen) call abort () if (len(ucp) .NE. ilen) call abort () hlp = ucp if (len(hlp) .NE. ilen) call abort () class default call abort() end select end subroutine subroutine sub2 character(len=:), allocatable, target :: dcl class(*), pointer :: ucp dcl = "ttt" ucp => dcl select type (ucp) type is (character(len=*)) if (len(ucp) .ne. 3) call abort () class default call abort() end select end subroutine subroutine sub3(ucp) character(len=:), allocatable :: hlp class(*), pointer :: ucp select type (ucp) type is (character(len=*)) if (len(ucp) .ne. 4) call abort () hlp = ucp if (len(hlp) .ne. 4) call abort () class default call abort() end select end subroutine subroutine sub4(ucp, ilen) character(len=:), allocatable :: hlp integer(4) :: ilen class(*) :: ucp select type (ucp) type is (character(len=*)) if (len(ucp) .ne. ilen) call abort () hlp = ucp if (len(hlp) .ne. ilen) call abort () class default call abort() end select end subroutine end program