gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90

! { 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