Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90 @ 144:8f4e72ab4e11
fix segmentation fault caused by nothing next cur_op to end
author | Takahiro SHIMIZU <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Sun, 23 Dec 2018 21:23:56 +0900 |
parents | 04ced10e8804 |
children |
line wrap: on
line source
! { dg-do run } ! ! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument ! ! Contributed by Miha Polajnar <polajnar.miha@gmail.com> MODULE m IMPLICIT NONE TYPE :: t CLASS(*), ALLOCATABLE :: x(:) CONTAINS PROCEDURE :: copy END TYPE t INTERFACE SUBROUTINE copy_proc_intr(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b END SUBROUTINE copy_proc_intr END INTERFACE CONTAINS SUBROUTINE copy(self,cp,a) CLASS(t), INTENT(IN) :: self PROCEDURE(copy_proc_intr) :: cp CLASS(*), INTENT(OUT) :: a(:) INTEGER :: i IF( .not.same_type_as(self%x(1),a(1)) ) STOP -1 DO i = 1, size(self%x) CALL cp(self%x(i),a(i)) END DO END SUBROUTINE copy END MODULE m PROGRAM main USE m IMPLICIT NONE INTEGER, PARAMETER :: n = 3, x(n) = [ 1, 2, 3 ] INTEGER :: copy_x(n) TYPE(t) :: test ALLOCATE(test%x(n),SOURCE=x) CALL test%copy(copy_int,copy_x) ! PRINT '(*(I0,:2X))', copy_x CONTAINS SUBROUTINE copy_int(a,b) CLASS(*), INTENT(IN) :: a CLASS(*), INTENT(OUT) :: b SELECT TYPE(a); TYPE IS(integer) SELECT TYPE(b); TYPE IS(integer) b = a END SELECT; END SELECT END SUBROUTINE copy_int END PROGRAM main