gcc/testsuite/gfortran.dg/unlimited_polymorphic_19.f90

   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