Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ! { dg-do run }
2 !
3 ! Testing fix for PR fortran/60255
4 !
5 ! Author: Andre Vehreschild <vehre@gmx.de>
6 !
7 MODULE m
8
9 contains
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
19 END MODULE
20
21 program 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
41 contains
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
105 end program
106