|
111
|
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
|
|
|
7 MODULE 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
|
|
|
20 CONTAINS
|
|
|
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
|
|
|
31 END MODULE m
|
|
|
32
|
|
|
33 PROGRAM 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
|
|
|
42 CONTAINS
|
|
|
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
|
|
|
51 END PROGRAM main
|
