1! { dg-do run }
2! Overwrite -pedantic setting:
3! { dg-options "-Wall" }
4!
5! Tests the fix for PR31668, in which %VAL was rejected for
6! module and internal procedures.
7!
8
9subroutine bmp_write(nx)
10  implicit none
11  integer, value :: nx
12  if(nx /= 10) call abort()
13  nx = 11
14  if(nx /= 11) call abort()
15end subroutine bmp_write
16
17module x
18 implicit none
19 ! The following interface does in principle
20 ! not match the procedure (missing VALUE attribute)
21 ! However, this occures in real-world code calling
22 ! C routines where an interface is better than
23 ! "external" only.
24 interface
25   subroutine bmp_write(nx)
26     integer, value :: nx
27   end subroutine bmp_write
28 end interface
29contains
30   SUBROUTINE Grid2BMP(NX)
31     INTEGER, INTENT(IN) :: NX
32     if(nx /= 10) call abort()
33     call bmp_write(%val(nx))
34     if(nx /= 10) call abort()
35   END SUBROUTINE Grid2BMP
36END module x
37
38! The following test is possible and
39! accepted by other compilers, but
40! does not make much sense.
41! Either one uses VALUE then %VAL is
42! not needed or the function will give
43! wrong results.
44!
45!subroutine test()
46!    implicit none
47!    integer :: n
48!    n = 5
49!    if(n /= 5) call abort()
50!    call test2(%VAL(n))
51!    if(n /= 5) call abort()
52!  contains
53!    subroutine test2(a)
54!      integer, value :: a
55!      if(a /= 5) call abort()
56!      a = 2
57!      if(a /= 2) call abort()
58!    end subroutine test2
59!end subroutine test
60
61program main
62  use x
63  implicit none
64!  external test
65  call Grid2BMP(10)
66!  call test()
67end program main
68