| ! { dg-do run } |
| ! |
| ! PR39630: Fortran 2003: Procedure pointer components. |
| ! |
| ! Basic test for PPCs with FUNCTION interface and NOPASS. |
| ! |
| ! Contributed by Janus Weil <janus@gcc.gnu.org> |
| |
| type t |
| procedure(fcn), pointer, nopass :: ppc |
| procedure(abstr), pointer, nopass :: ppc1 |
| integer :: i |
| end type |
| |
| abstract interface |
| integer function abstr(x) |
| integer, intent(in) :: x |
| end function |
| end interface |
| |
| type(t) :: obj |
| procedure(fcn), pointer :: f |
| integer :: base |
| |
| intrinsic :: iabs |
| |
| ! Check with interface from contained function |
| obj%ppc => fcn |
| base=obj%ppc(2) |
| if (base/=4) STOP 1 |
| call foo (obj%ppc,3) |
| |
| ! Check with abstract interface |
| obj%ppc1 => obj%ppc |
| base=obj%ppc1(4) |
| if (base/=8) STOP 1 |
| call foo (obj%ppc1,5) |
| |
| ! Check compatibility components with non-components |
| f => obj%ppc |
| base=f(6) |
| if (base/=12) STOP 1 |
| call foo (f,7) |
| |
| contains |
| |
| integer function fcn(x) |
| integer, intent(in) :: x |
| fcn = 2 * x |
| end function |
| |
| subroutine foo (arg, i) |
| procedure (fcn), pointer :: arg |
| integer :: i |
| if (arg(i)/=2*i) STOP 1 |
| end subroutine |
| |
| end |