3 ! PR 64209: [OOP] runtime segfault with CLASS(*), INTENT(OUT) dummy argument
5 ! Contributed by Miha Polajnar <polajnar.miha@gmail.com>
10 CLASS(*), ALLOCATABLE
:: x(:)
15 SUBROUTINE copy_proc_intr(a
,b
)
16 CLASS(*), INTENT(IN
) :: a
17 CLASS(*), INTENT(OUT
) :: b
18 END SUBROUTINE copy_proc_intr
21 SUBROUTINE copy(self
,cp
,a
)
22 CLASS(t
), INTENT(IN
) :: self
23 PROCEDURE(copy_proc_intr
) :: cp
24 CLASS(*), INTENT(OUT
) :: a(:)
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
))
36 INTEGER, PARAMETER :: n
= 3, x(n
) = [ 1, 2, 3 ]
39 ALLOCATE(test
%x(n
),SOURCE
=x
)
40 CALL test
%copy(copy_int
,copy_x
)
41 ! PRINT '(*(I0,:2X))', copy_x
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)
49 END SELECT
; END SELECT
50 END SUBROUTINE copy_int
53 ! { dg-final { cleanup-modules "m" } }