fix pr/45972
[official-gcc.git] / gcc / testsuite / gfortran.dg / char_result_4.f90
blob5e4f58e188bbef7067af089a58a519e74eda71b1
1 ! Like char_result_3.f90, but the array arguments are pointers.
2 ! { dg-do run }
3 pure elemental function double (x)
4 integer, intent (in) :: x
5 integer :: double
6 double = x * 2
7 end function double
9 program main
10 implicit none
12 interface
13 pure elemental function double (x)
14 integer, intent (in) :: x
15 integer :: double
16 end function double
17 end interface
19 integer, dimension (100:104), target :: a
20 integer, dimension (:), pointer :: ap
21 integer :: i, lower
23 a = (/ (i + 5, i = 0, 4) /)
24 ap => a
25 lower = lbound(a,dim=1)
27 call test (f1 (ap), 35)
28 call test (f2 (ap), 115)
29 call test (f3 (ap), 60)
30 call test (f4 (ap, 104, 2), 21)
31 contains
32 function f1 (array)
33 integer, dimension (:), pointer :: array
34 character (len = sum (array)) :: f1
35 f1 = ''
36 end function f1
38 function f2 (array)
39 integer, dimension (:), pointer :: array
40 character (len = array (101) + a (104) + 100) :: f2
41 f2 = ''
42 end function f2
44 function f3 (array)
45 integer, dimension (:), pointer :: array
46 character (len = sum (double (array (101:)))) :: f3
47 f3 = ''
48 end function f3
50 function f4 (array, upper, stride)
51 integer, dimension (:), pointer :: array
52 integer :: upper, stride
53 character (len = sum (array (lower:upper:stride))) :: f4
54 f4 = ''
55 end function f4
57 subroutine test (string, length)
58 character (len = *) :: string
59 integer, intent (in) :: length
60 if (len (string) .ne. length) call abort
61 end subroutine test
62 end program main