gcc/testsuite/gfortran.dg/proc_decl_2.f90

   1 ! { dg-do run }
   2 ! Various runtime tests of PROCEDURE declarations.
   3 ! Contributed by Janus Weil <jaydub66@gmail.com>
   4
   5 module m
   6
   7   abstract interface
   8     subroutine csub() bind(c)
   9     end subroutine csub
  10   end interface
  11
  12   procedure():: mp1
  13   procedure(real), private:: mp2
  14   procedure(mfun), public:: mp3
  15   procedure(csub), public, bind(c) :: c, d
  16   procedure(csub), public, bind(c, name="myB") :: b
  17
  18 contains
  19
  20   real function mfun(x,y)
  21     real x,y
  22     mfun=4.2
  23   end function
  24
  25   subroutine bar(a,b)
  26     implicit none
  27     interface
  28       subroutine a()
  29       end subroutine a
  30     end interface
  31     optional ::  a
  32     procedure(a), optional :: b
  33   end subroutine bar
  34
  35 end module
  36
  37
  38 program p
  39   implicit none
  40
  41   abstract interface
  42     subroutine abssub(x)
  43       real x
  44     end subroutine
  45   end interface
  46
  47   integer i
  48   real r
  49
  50   procedure(integer):: p1
  51   procedure(fun):: p2
  52   procedure(abssub):: p3
  53   procedure(sub):: p4
  54   procedure():: p5
  55   procedure(p4):: p6
  56   procedure(integer) :: p7
  57
  58   i=p1()
  59   if (i /= 5) call abort()
  60   i=p2(3.1)
  61   if (i /= 3) call abort()
  62   r=4.2
  63   call p3(r)
  64   if (abs(r-5.2)>1e-6) call abort()
  65   call p4(r)
  66   if (abs(r-3.7)>1e-6) call abort()
  67   call p5()
  68   call p6(r)
  69   if (abs(r-7.4)>1e-6) call abort()
  70   i=p7(4)
  71   if (i /= -8) call abort()
  72   r=dummytest(p3)
  73   if (abs(r-2.1)>1e-6) call abort()
  74
  75 contains
  76
  77   integer function fun(x)
  78     real x
  79     fun=7
  80   end function
  81
  82   subroutine sub(x)
  83     real x
  84   end subroutine
  85
  86   real function dummytest(dp)
  87     procedure(abssub):: dp
  88     real y
  89     y=1.1
  90     call dp(y)
  91     dummytest=y
  92   end function
  93
  94 end program p
  95
  96
  97 integer function p1()
  98   p1 = 5
  99 end function
 100
 101 integer function p2(x)
 102   real x
 103   p2 = int(x)
 104 end function
 105
 106 subroutine p3(x)
 107   real,intent(inout):: x
 108   x=x+1.0
 109 end subroutine
 110
 111 subroutine p4(x)
 112   real,intent(inout):: x
 113   x=x-1.5
 114 end subroutine
 115
 116 subroutine p5()
 117 end subroutine
 118
 119 subroutine p6(x)
 120   real,intent(inout):: x
 121   x=x*2.
 122 end subroutine
 123
 124 function p7(x)
 125  implicit none
 126  integer :: x, p7
 127  p7 = x*(-2)
 128 end function