1! { dg-do run } 2! 3! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument 4! 5! Contributed by Miha Polajnar <polajnar.miha@gmail.com> 6 7MODULE m 8 IMPLICIT NONE 9 TYPE :: t 10 CLASS(*), ALLOCATABLE :: x(:) 11 CONTAINS 12 PROCEDURE :: copy 13 END TYPE t 14 INTERFACE 15 SUBROUTINE copy_proc_intr(a,b) 16 CLASS(*), INTENT(IN) :: a 17 CLASS(*), INTENT(OUT) :: b 18 END SUBROUTINE copy_proc_intr 19 END INTERFACE 20CONTAINS 21 SUBROUTINE copy(self,cp,a) 22 CLASS(t), INTENT(IN) :: self 23 PROCEDURE(copy_proc_intr) :: cp 24 CLASS(*), INTENT(OUT) :: a(:) 25 INTEGER :: i 26 IF( .not.same_type_as(self%x(1),a(1)) ) STOP -1 27 DO i = 1, size(self%x) 28 CALL cp(self%x(i),a(i)) 29 END DO 30 END SUBROUTINE copy 31END MODULE m 32 33PROGRAM main 34 USE m 35 IMPLICIT NONE 36 INTEGER, PARAMETER :: n = 3, x(n) = [ 1, 2, 3 ] 37 INTEGER :: copy_x(n) 38 TYPE(t) :: test 39 ALLOCATE(test%x(n),SOURCE=x) 40 CALL test%copy(copy_int,copy_x) 41! PRINT '(*(I0,:2X))', copy_x 42CONTAINS 43 SUBROUTINE copy_int(a,b) 44 CLASS(*), INTENT(IN) :: a 45 CLASS(*), INTENT(OUT) :: b 46 SELECT TYPE(a); TYPE IS(integer) 47 SELECT TYPE(b); TYPE IS(integer) 48 b = a 49 END SELECT; END SELECT 50 END SUBROUTINE copy_int 51END PROGRAM main 52 53! { dg-final { cleanup-modules "m" } } 54