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