gcc/testsuite/gfortran.dg/proc_ptr_comp_8.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 40164: Fortran 2003: "Arrays of procedure pointers" (using PPCs)
   4 !
   5 ! Original test case by Barron Bichon <barron.bichon@swri.org>
   6 ! Adapted by Janus Weil <janus@gcc.gnu.org>
   7
   8 PROGRAM test_prog
   9
  10   ABSTRACT INTERFACE
  11   FUNCTION fn_template(n,x) RESULT(y)
  12     INTEGER, INTENT(in) :: n
  13     REAL, INTENT(in) :: x(n)
  14     REAL :: y(n)
  15   END FUNCTION fn_template
  16   END INTERFACE
  17
  18   TYPE PPA
  19     PROCEDURE(fn_template), POINTER, NOPASS :: f
  20   END TYPE PPA
  21
  22  TYPE ProcPointerArray
  23    PROCEDURE(add), POINTER, NOPASS :: f
  24  END TYPE ProcPointerArray
  25
  26  TYPE (ProcPointerArray) :: f_array(3)
  27  PROCEDURE(add), POINTER :: f
  28  real :: r
  29
  30  f_array(1)%f => add
  31  f => f_array(1)%f
  32  f_array(2)%f => sub
  33  f_array(3)%f => f_array(1)%f
  34
  35  r = f(1.,2.)
  36  if (abs(r-3.)>1E-3) call abort()
  37  r = f_array(1)%f(4.,2.)
  38  if (abs(r-6.)>1E-3) call abort()
  39  r = f_array(2)%f(5.,3.)
  40  if (abs(r-2.)>1E-3) call abort()
  41  if (abs(f_array(1)%f(1.,3.)-f_array(3)%f(2.,2.))>1E-3) call abort()
  42
  43 CONTAINS
  44
  45  FUNCTION add(a,b) RESULT(sum)
  46    REAL, INTENT(in) :: a, b
  47    REAL :: sum
  48    sum = a + b
  49  END FUNCTION add
  50
  51  FUNCTION sub(a,b) RESULT(diff)
  52    REAL, INTENT(in) :: a, b
  53    REAL :: diff
  54    diff = a - b
  55  END FUNCTION sub
  56
  57 END PROGRAM test_prog
  58