gcc/testsuite/gfortran.dg/proc_decl_2.f90

! { dg-do run }
! Various runtime tests of PROCEDURE declarations.
! Contributed by Janus Weil <jaydub66@gmail.com>

module m

  use ISO_C_BINDING

  abstract interface
    subroutine csub() bind(c)
    end subroutine csub
  end interface

  integer, parameter :: ckind = C_FLOAT_COMPLEX
  abstract interface
    function stub() bind(C)
      import ckind
      complex(ckind) stub
    end function
  end interface

  procedure():: mp1
  procedure(real), private:: mp2
  procedure(mfun), public:: mp3
  procedure(csub), public, bind(c) :: c, d
  procedure(csub), public, bind(c, name="myB") :: b
  procedure(stub), bind(C) :: e

contains

  real function mfun(x,y)
    real x,y
    mfun=4.2
  end function

  subroutine bar(a,b)
    implicit none
    interface
      subroutine a()
      end subroutine a
    end interface
    optional ::  a
    procedure(a), optional :: b
  end subroutine bar

  subroutine bar2(x)
    abstract interface
      character function abs_fun()
      end function
    end interface
    procedure(abs_fun):: x
  end subroutine


end module


program p
  implicit none

  abstract interface
    subroutine abssub(x)
      real x
    end subroutine
  end interface

  integer i
  real r

  procedure(integer):: p1
  procedure(fun):: p2
  procedure(abssub):: p3
  procedure(sub):: p4
  procedure():: p5
  procedure(p4):: p6
  procedure(integer) :: p7

  i=p1()
  if (i /= 5) STOP 1
  i=p2(3.1)
  if (i /= 3) STOP 2
  r=4.2
  call p3(r)
  if (abs(r-5.2)>1e-6) STOP 3
  call p4(r)
  if (abs(r-3.7)>1e-6) STOP 4
  call p5()
  call p6(r)
  if (abs(r-7.4)>1e-6) STOP 5
  i=p7(4)
  if (i /= -8) STOP 6
  r=dummytest(p3)
  if (abs(r-2.1)>1e-6) STOP 7

contains

  integer function fun(x)
    real x
    fun=7
  end function

  subroutine sub(x)
    real x
  end subroutine

  real function dummytest(dp)
    procedure(abssub):: dp
    real y
    y=1.1
    call dp(y)
    dummytest=y
  end function

end program p


integer function p1()
  p1 = 5
end function

integer function p2(x)
  real x
  p2 = int(x)
end function

subroutine p3(x)
  real :: x
  x=x+1.0
end subroutine

subroutine p4(x)
  real :: x
  x=x-1.5
end subroutine

subroutine p5()
end subroutine

subroutine p6(x)
  real :: x
  x=x*2.
end subroutine

function p7(x)
 implicit none
 integer :: x, p7
 p7 = x*(-2)
end function