2017-02-20 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / testsuite / gfortran.dg / elemental_subroutine_2.f90
blobb7d9afe9e0854ac57753946e6862e0d63a70b2e4
1 ! { dg-do run }
2 ! Test the fix for pr22146, where and elemental subroutine with
3 ! array actual arguments would cause an ICE in gfc_conv_function_call.
4 ! This test checks that the main uses for elemental subroutines work
5 ! correctly; namely, as module procedures and as procedures called
6 ! from elemental functions. The compiler would ICE on the former with
7 ! the first version of the patch.
9 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
11 module type
12 type itype
13 integer :: i
14 character(1) :: ch
15 end type itype
16 end module type
18 module assign
19 interface assignment (=)
20 module procedure itype_to_int
21 end interface
22 contains
23 elemental subroutine itype_to_int (i, it)
24 use type
25 type(itype), intent(in) :: it
26 integer, intent(out) :: i
27 i = it%i
28 end subroutine itype_to_int
30 elemental function i_from_itype (it) result (i)
31 use type
32 type(itype), intent(in) :: it
33 integer :: i
34 i = it
35 end function i_from_itype
37 end module assign
39 program test_assign
40 use type
41 use assign
42 type(itype) :: x(2, 2)
43 integer :: i(2, 2)
45 ! Test an elemental subroutine call from an elementary function.
46 x = reshape ((/(itype (j, "a"), j = 1,4)/), (/2,2/))
47 forall (j = 1:2, k = 1:2)
48 i(j, k) = i_from_itype (x (j, k))
49 end forall
50 if (any(reshape (i, (/4/)).ne.(/1,2,3,4/))) call abort ()
52 ! Check the interface assignment (not part of the patch).
53 x = reshape ((/(itype (j**2, "b"), j = 1,4)/), (/2,2/))
54 i = x
55 if (any(reshape (i, (/4/)).ne.(/1,4,9,16/))) call abort ()
57 ! Use the interface assignment within a forall block.
58 x = reshape ((/(itype (j**3, "c"), j = 1,4)/), (/2,2/))
59 forall (j = 1:2, k = 1:2)
60 i(j, k) = x (j, k)
61 end forall
62 if (any(reshape (i, (/4/)).ne.(/1,8,27,64/))) call abort ()
64 end program test_assign