1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
! { 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
call sub1 ("long test string", 16)
call sub2 ()
S = "test"
ucp => S
call sub3 (ucp)
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
|
