gcc/testsuite/gfortran.dg/proc_ptr_48.f90

   1 ! { dg-do run }
   2 !
   3 ! Checks the fix for PR68196, comment #8
   4 !
   5 ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
   6 !
   7   type  Bug                                  ! Failed at trans--array.c:8269
   8     real, allocatable :: scalar
   9     procedure(boogInterface),pointer :: boog
  10   end type
  11   interface
  12     function boogInterface(A) result(C)
  13       import Bug
  14       class(Bug) A
  15       type(Bug)  C
  16     end function
  17   end interface
  18
  19   real, parameter :: ninetynine = 99.0
  20   real, parameter :: onenineeight = 198.0
  21
  22   type(bug) :: actual, res
  23
  24   actual%scalar = ninetynine
  25   actual%boog => boogImplementation
  26
  27   res = actual%boog ()                       ! Failed on bug in expr.c:3933
  28   if (res%scalar .ne. onenineeight) STOP 1
  29
  30 ! Make sure that the procedure pointer is assigned correctly
  31   if (actual%scalar .ne. ninetynine) STOP 2
  32   actual = res%boog ()
  33   if (actual%scalar .ne. onenineeight) STOP 3
  34
  35 ! Deallocate so that we can use valgrind to check for memory leaks
  36   deallocate (res%scalar, actual%scalar)
  37
  38 contains
  39     function boogImplementation(A) result(C) ! Failed at trans--array.c:8078
  40       class(Bug) A
  41       type(Bug)  C
  42       select type (A)
  43         type is (bug)
  44           C = A
  45           C%scalar = onenineeight
  46         class default
  47           STOP 4
  48       end select
  49     end function
  50 end