gcc/testsuite/gfortran.dg/entry_13.f90

   1 ! { dg-do run }
   2 ! Tests the fix for pr31214, in which the typespec for the entry would be lost,
   3 ! thereby causing the function to be disallowed, since the function and entry
   4 ! types did not match.
   5 !
   6 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
   7 !
   8 module type_mod
   9   implicit none
  10
  11   type x
  12      real x
  13   end type x
  14   type y
  15      real x
  16   end type y
  17   type z
  18      real x
  19   end type z
  20
  21   interface assignment(=)
  22      module procedure equals
  23   end interface assignment(=)
  24
  25   interface operator(//)
  26      module procedure a_op_b, b_op_a
  27   end interface operator(//)
  28
  29   interface operator(==)
  30      module procedure a_po_b, b_po_a
  31   end interface operator(==)
  32
  33   contains
  34      subroutine equals(x,y)
  35         type(z), intent(in) :: y
  36         type(z), intent(out) :: x
  37
  38         x%x = y%x
  39      end subroutine equals
  40
  41      function a_op_b(a,b)
  42         type(x), intent(in) :: a
  43         type(y), intent(in) :: b
  44         type(z) a_op_b
  45         type(z) b_op_a
  46         a_op_b%x = a%x + b%x
  47         return
  48      entry b_op_a(b,a)
  49         b_op_a%x = a%x - b%x
  50      end function a_op_b
  51
  52      function a_po_b(a,b)
  53         type(x), intent(in) :: a
  54         type(y), intent(in) :: b
  55         type(z) a_po_b
  56         type(z) b_po_a
  57      entry b_po_a(b,a)
  58         a_po_b%x = a%x/b%x
  59      end function a_po_b
  60 end module type_mod
  61
  62 program test
  63   use type_mod
  64   implicit none
  65   type(x) :: x1 = x(19.0_4)
  66   type(y) :: y1 = y(7.0_4)
  67   type(z) z1
  68
  69   z1 = x1//y1
  70   if (abs(z1%x - (19.0_4 + 7.0_4)) > epsilon(x1%x)) call abort ()
  71   z1 = y1//x1
  72   if (abs(z1%x - (19.0_4 - 7.0_4)) > epsilon(x1%x)) call abort ()
  73
  74   z1 = x1==y1
  75   if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) call abort ()
  76   z1 = y1==x1
  77   if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) call abort ()
  78 end program test