1! { dg-do run } 2! 3! Testing fix for PR fortran/60255 4! 5! Author: Andre Vehreschild <vehre@gmx.de> 6! 7MODULE m 8 9contains 10 subroutine bar (arg, res) 11 class(*) :: arg 12 character(100) :: res 13 select type (w => arg) 14 type is (character(*)) 15 write (res, '(I2)') len(w) 16 end select 17 end subroutine 18 19END MODULE 20 21program test 22 use m; 23 implicit none 24 character(LEN=:), allocatable, target :: S 25 character(LEN=100) :: res 26 class(*), pointer :: ucp, ucp2 27 call sub1 ("long test string", 16) 28 call sub2 () 29 S = "test" 30 ucp => S 31 call sub3 (ucp) 32 allocate (ucp2, source=ucp) 33 call sub3 (ucp2) 34 call sub4 (S, 4) 35 call sub4 ("This is a longer string.", 24) 36 call bar (S, res) 37 if (trim (res) .NE. " 4") call abort () 38 call bar(ucp, res) 39 if (trim (res) .NE. " 4") call abort () 40 41contains 42 43 subroutine sub1(dcl, ilen) 44 character(len=*), target :: dcl 45 integer(4) :: ilen 46 character(len=:), allocatable :: hlp 47 class(*), pointer :: ucp 48 49 ucp => dcl 50 51 select type (ucp) 52 type is (character(len=*)) 53 if (len(dcl) .NE. ilen) call abort () 54 if (len(ucp) .NE. ilen) call abort () 55 hlp = ucp 56 if (len(hlp) .NE. ilen) call abort () 57 class default 58 call abort() 59 end select 60 end subroutine 61 62 subroutine sub2 63 character(len=:), allocatable, target :: dcl 64 class(*), pointer :: ucp 65 66 dcl = "ttt" 67 ucp => dcl 68 69 select type (ucp) 70 type is (character(len=*)) 71 if (len(ucp) .ne. 3) call abort () 72 class default 73 call abort() 74 end select 75 end subroutine 76 77 subroutine sub3(ucp) 78 character(len=:), allocatable :: hlp 79 class(*), pointer :: ucp 80 81 select type (ucp) 82 type is (character(len=*)) 83 if (len(ucp) .ne. 4) call abort () 84 hlp = ucp 85 if (len(hlp) .ne. 4) call abort () 86 class default 87 call abort() 88 end select 89 end subroutine 90 91 subroutine sub4(ucp, ilen) 92 character(len=:), allocatable :: hlp 93 integer(4) :: ilen 94 class(*) :: ucp 95 96 select type (ucp) 97 type is (character(len=*)) 98 if (len(ucp) .ne. ilen) call abort () 99 hlp = ucp 100 if (len(hlp) .ne. ilen) call abort () 101 class default 102 call abort() 103 end select 104 end subroutine 105end program 106 107