Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/pointer_array_1.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 ! Check the fix for PR34640 comments 1 and 3.
4 !
5 ! This involves passing and returning pointer array components that
6 ! point to components of arrays of derived types.
7 !
8 MODULE test
9 IMPLICIT NONE
10 TYPE :: my_type
11 INTEGER :: value
12 integer :: tag
13 END TYPE
14 CONTAINS
15 SUBROUTINE get_values(values, switch)
16 INTEGER, POINTER :: values(:)
17 integer :: switch
18 TYPE(my_type), POINTER :: d(:)
19 allocate (d, source = [my_type(1,101), my_type(2,102)])
20 if (switch .eq. 1) then
21 values => d(:)%value
22 if (any (values .ne. [1,2])) print *, values(2)
23 else
24 values => d(:)%tag
25 if (any (values .ne. [101,102])) call abort
26 end if
27 END SUBROUTINE
28
29 function return_values(switch) result (values)
30 INTEGER, POINTER :: values(:)
31 integer :: switch
32 TYPE(my_type), POINTER :: d(:)
33 allocate (d, source = [my_type(1,101), my_type(2,102)])
34 if (switch .eq. 1) then
35 values => d(:)%value
36 if (any (values .ne. [1,2])) call abort
37 else
38 values => d(:)%tag
39 if (any (values([2,1]) .ne. [102,101])) call abort
40 end if
41 END function
42 END MODULE
43
44 use test
45 integer, pointer :: x(:)
46 type :: your_type
47 integer, pointer :: x(:)
48 end type
49 type(your_type) :: y
50
51 call get_values (x, 1)
52 if (any (x .ne. [1,2])) call abort
53 call get_values (y%x, 2)
54 if (any (y%x .ne. [101,102])) call abort
55
56 x => return_values (2)
57 if (any (x .ne. [101,102])) call abort
58 y%x => return_values (1)
59 if (any (y%x .ne. [1,2])) call abort
60 end