mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-28 18:56:06 +00:00
59 lines
1.2 KiB
Fortran
59 lines
1.2 KiB
Fortran
! { dg-do run }
|
|
!
|
|
! PR 40164: Fortran 2003: "Arrays of procedure pointers" (using PPCs)
|
|
!
|
|
! Original test case by Barron Bichon <barron.bichon@swri.org>
|
|
! Adapted by Janus Weil <janus@gcc.gnu.org>
|
|
|
|
PROGRAM test_prog
|
|
|
|
ABSTRACT INTERFACE
|
|
FUNCTION fn_template(n,x) RESULT(y)
|
|
INTEGER, INTENT(in) :: n
|
|
REAL, INTENT(in) :: x(n)
|
|
REAL :: y(n)
|
|
END FUNCTION fn_template
|
|
END INTERFACE
|
|
|
|
TYPE PPA
|
|
PROCEDURE(fn_template), POINTER, NOPASS :: f
|
|
END TYPE PPA
|
|
|
|
TYPE ProcPointerArray
|
|
PROCEDURE(add), POINTER, NOPASS :: f
|
|
END TYPE ProcPointerArray
|
|
|
|
TYPE (ProcPointerArray) :: f_array(3)
|
|
PROCEDURE(add), POINTER :: f
|
|
real :: r
|
|
|
|
f_array(1)%f => add
|
|
f => f_array(1)%f
|
|
f_array(2)%f => sub
|
|
f_array(3)%f => f_array(1)%f
|
|
|
|
r = f(1.,2.)
|
|
if (abs(r-3.)>1E-3) STOP 1
|
|
r = f_array(1)%f(4.,2.)
|
|
if (abs(r-6.)>1E-3) STOP 2
|
|
r = f_array(2)%f(5.,3.)
|
|
if (abs(r-2.)>1E-3) STOP 3
|
|
if (abs(f_array(1)%f(1.,3.)-f_array(3)%f(2.,2.))>1E-3) STOP 4
|
|
|
|
CONTAINS
|
|
|
|
FUNCTION add(a,b) RESULT(sum)
|
|
REAL, INTENT(in) :: a, b
|
|
REAL :: sum
|
|
sum = a + b
|
|
END FUNCTION add
|
|
|
|
FUNCTION sub(a,b) RESULT(diff)
|
|
REAL, INTENT(in) :: a, b
|
|
REAL :: diff
|
|
diff = a - b
|
|
END FUNCTION sub
|
|
|
|
END PROGRAM test_prog
|
|
|