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   use ISO_C_BINDING
   8
   9   abstract interface
  10     subroutine csub() bind(c)
  11     end subroutine csub
  12   end interface
  13
  14   integer, parameter :: ckind = C_FLOAT_COMPLEX
  15   abstract interface
  16     function stub() bind(C)
  17       import ckind
  18       complex(ckind) stub
  19     end function
  20   end interface
  21
  22   procedure():: mp1
  23   procedure(real), private:: mp2
  24   procedure(mfun), public:: mp3
  25   procedure(csub), public, bind(c) :: c, d
  26   procedure(csub), public, bind(c, name="myB") :: b
  27   procedure(stub), bind(C) :: e
  28
  29 contains
  30
  31   real function mfun(x,y)
  32     real x,y
  33     mfun=4.2
  34   end function
  35
  36   subroutine bar(a,b)
  37     implicit none
  38     interface
  39       subroutine a()
  40       end subroutine a
  41     end interface
  42     optional ::  a
  43     procedure(a), optional :: b
  44   end subroutine bar
  45
  46   subroutine bar2(x)
  47     abstract interface
  48       character function abs_fun()
  49       end function
  50     end interface
  51     procedure(abs_fun):: x
  52   end subroutine
  53
  54
  55 end module
  56
  57
  58 program p
  59   implicit none
  60
  61   abstract interface
  62     subroutine abssub(x)
  63       real x
  64     end subroutine
  65   end interface
  66
  67   integer i
  68   real r
  69
  70   procedure(integer):: p1
  71   procedure(fun):: p2
  72   procedure(abssub):: p3
  73   procedure(sub):: p4
  74   procedure():: p5
  75   procedure(p4):: p6
  76   procedure(integer) :: p7
  77
  78   i=p1()
  79   if (i /= 5) call abort()
  80   i=p2(3.1)
  81   if (i /= 3) call abort()
  82   r=4.2
  83   call p3(r)
  84   if (abs(r-5.2)>1e-6) call abort()
  85   call p4(r)
  86   if (abs(r-3.7)>1e-6) call abort()
  87   call p5()
  88   call p6(r)
  89   if (abs(r-7.4)>1e-6) call abort()
  90   i=p7(4)
  91   if (i /= -8) call abort()
  92   r=dummytest(p3)
  93   if (abs(r-2.1)>1e-6) call abort()
  94
  95 contains
  96
  97   integer function fun(x)
  98     real x
  99     fun=7
 100   end function
 101
 102   subroutine sub(x)
 103     real x
 104   end subroutine
 105
 106   real function dummytest(dp)
 107     procedure(abssub):: dp
 108     real y
 109     y=1.1
 110     call dp(y)
 111     dummytest=y
 112   end function
 113
 114 end program p
 115
 116
 117 integer function p1()
 118   p1 = 5
 119 end function
 120
 121 integer function p2(x)
 122   real x
 123   p2 = int(x)
 124 end function
 125
 126 subroutine p3(x)
 127   real,intent(inout):: x
 128   x=x+1.0
 129 end subroutine
 130
 131 subroutine p4(x)
 132   real,intent(inout):: x
 133   x=x-1.5
 134 end subroutine
 135
 136 subroutine p5()
 137 end subroutine
 138
 139 subroutine p6(x)
 140   real,intent(inout):: x
 141   x=x*2.
 142 end subroutine
 143
 144 function p7(x)
 145  implicit none
 146  integer :: x, p7
 147  p7 = x*(-2)
 148 end function