view gcc/testsuite/gfortran.dg/proc_ptr_48.f90 @ 152:2b5abeee2509

update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents 84e7813d76e9
children
line wrap: on
line source

! { dg-do run }
!
! Checks the fix for PR68196, comment #8
!
! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
!
  type  Bug                                  ! Failed at trans--array.c:8269
    real, allocatable :: scalar
    procedure(boogInterface),pointer :: boog
  end type
  interface
    function boogInterface(A) result(C)
      import Bug
      class(Bug) A
      type(Bug)  C
    end function
  end interface

  real, parameter :: ninetynine = 99.0
  real, parameter :: onenineeight = 198.0

  type(bug) :: actual, res

  actual%scalar = ninetynine
  actual%boog => boogImplementation

  res = actual%boog ()                       ! Failed on bug in expr.c:3933
  if (res%scalar .ne. onenineeight) STOP 1

! Make sure that the procedure pointer is assigned correctly
  if (actual%scalar .ne. ninetynine) STOP 2
  actual = res%boog ()
  if (actual%scalar .ne. onenineeight) STOP 3

! Deallocate so that we can use valgrind to check for memory leaks
  deallocate (res%scalar, actual%scalar)

contains
    function boogImplementation(A) result(C) ! Failed at trans--array.c:8078
      class(Bug) A
      type(Bug)  C
      select type (A)
        type is (bug)
          C = A
          C%scalar = onenineeight
        class default
          STOP 4
      end select
    end function
end