gcc/testsuite/gfortran.dg/proc_ptr_result_8.f90

   1 ! { dg-do compile }
   2 ! Test fix for PR54286.
   3 !
   4 ! Contributed by Janus Weil  <janus@gcc.gnu.org>
   5 ! Module 'm' added later because original fix missed possibility of
   6 ! null interfaces - thanks to Dominique Dhumieres  <dominiq@lps.ens.fr>
   7 !
   8 module m
   9   type :: foobar
  10     real, pointer :: array(:)
  11     procedure (), pointer, nopass :: f
  12   end type
  13 contains
  14   elemental subroutine fooAssgn (a1, a2)
  15     type(foobar), intent(out) :: a1
  16     type(foobar), intent(in) :: a2
  17     allocate (a1%array(size(a2%array)))
  18     a1%array = a2%array
  19     a1%f => a2%f
  20   end subroutine
  21 end module m
  22
  23 implicit integer (a)
  24 type :: t
  25   procedure(a), pointer, nopass :: p
  26 end type
  27 type(t) :: x
  28
  29 ! We cannot use iabs directly as it is elemental
  30 abstract interface
  31   integer pure function interf_iabs(x)
  32     integer, intent(in) :: x
  33   end function interf_iabs
  34 end interface
  35
  36 procedure(interf_iabs), pointer :: pp
  37 procedure(foo), pointer :: pp1
  38
  39 x%p => a     ! ok
  40 if (x%p(0) .ne. loc(foo)) STOP 1
  41 if (x%p(1) .ne. loc(iabs)) STOP 2
  42
  43 x%p => a(1)  ! { dg-error "PROCEDURE POINTER mismatch in function result" }
  44
  45 pp => a(1)   ! ok
  46 if (pp(-99) .ne. iabs(-99)) STOP 3
  47
  48 pp1 => a(2)   ! ok
  49 if (pp1(-99) .ne. -iabs(-99)) STOP 4
  50
  51 pp => a  ! { dg-error "PROCEDURE POINTER mismatch in function result" }
  52
  53 contains
  54
  55   function a (c) result (b)
  56     integer, intent(in) :: c
  57     procedure(interf_iabs), pointer :: b
  58     if (c .eq. 1) then
  59       b => iabs
  60     else
  61       b => foo
  62     end if
  63   end function
  64
  65   pure integer function foo (arg)
  66     integer, intent (in) :: arg
  67     foo = -iabs(arg)
  68   end function
  69 end