gcc/testsuite/gfortran.dg/alloc_comp_result_3.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR96495 - segfaults at runtime at locations below.
   4 !
   5 ! Contributed by Paul Luckner  <paul.luckner@rwth-aachen.de>
   6 !
   7 module foo_m
   8
   9   implicit none
  10
  11   type foo
  12     integer, allocatable :: j(:)
  13   end type
  14
  15   interface operator(.unary.)
  16     module procedure neg_foo
  17   end interface
  18
  19   interface operator(.binary.)
  20     module procedure foo_sub_foo
  21   end interface
  22
  23   interface operator(.binaryElemental.)
  24     module procedure foo_add_foo
  25   end interface
  26
  27 contains
  28
  29   elemental function foo_add_foo(f, g) result(h)
  30     !! an example for an elemental binary operator
  31     type(foo), intent(in) :: f, g
  32     type(foo)             :: h
  33
  34     allocate (h%j(size(f%j)), source = f%j+g%j)
  35   end function
  36
  37   elemental function foo_sub_foo(f, g) result(h)
  38     !! an example for an elemental binary operator
  39     type(foo), intent(in) :: f, g
  40     type(foo)             :: h
  41
  42     allocate (h%j(size(f%j)), source = f%j-3*g%j)
  43   end function
  44
  45   pure function neg_foo(f) result(g)
  46     !! an example for a unary operator
  47     type(foo), intent(in) :: f
  48     type(foo)             :: g
  49
  50     allocate (g%j(size(f%j)), source = -f%j)
  51   end function
  52
  53 end module
  54
  55 program main_tmp
  56
  57   use foo_m
  58
  59   implicit none
  60
  61   type(foo) f, g(2)
  62
  63   allocate (f%j(3))
  64   f%j = [2, 3, 4]
  65
  66   g = f
  67   if (any (g(2)%j .ne. [2, 3, 4])) stop 1
  68
  69   g = g .binaryElemental. (f .binary. f)     ! threw "Segmentation fault"
  70   if (any (g(2)%j .ne. [-2,-3,-4])) stop 2
  71
  72   g = g .binaryElemental. (  .unary.  f)     ! threw "Segmentation fault"
  73   if (any (g(2)%j .ne. [-4,-6,-8])) stop 3
  74
  75 end program