gcc/testsuite/gfortran.dg/interface_50.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Tests the fix for PR98498, which was subject to an interpretation request
   5 ! as to whether or not the interface operator overrode the intrinsic use.
   6 ! (See PR for correspondence)
   7 !
   8 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   9 !
  10 MODULE mytypes
  11   IMPLICIT none
  12
  13   TYPE pvar
  14      character(len=20) :: name
  15      integer           :: level
  16   end TYPE pvar
  17
  18   interface operator (==)
  19      module procedure star_eq
  20   end interface
  21
  22   interface operator (.not.)
  23      module procedure star_not
  24   end interface
  25
  26 contains
  27   function star_eq(a, b)
  28     implicit none
  29     class(*), intent(in) :: a, b
  30     logical :: star_eq
  31     select type (a)
  32       type is (pvar)
  33       select type (b)
  34         type is (pvar)
  35           if((a%level .eq. b%level) .and. (a%name .eq. b%name)) then
  36             star_eq = .true.
  37           else
  38             star_eq = .false.
  39           end if
  40         type is (integer)
  41           star_eq = (a%level == b)
  42       end select
  43       class default
  44         star_eq = .false.
  45     end select
  46   end function star_eq
  47
  48   function star_not (a)
  49     implicit none
  50     class(*), intent(in) :: a
  51     type(pvar) :: star_not
  52     select type (a)
  53       type is (pvar)
  54         star_not = a
  55         star_not%level = -star_not%level
  56       type is (real)
  57         star_not = pvar ("real", -int(a))
  58       class default
  59         star_not = pvar ("noname", 0)
  60     end select
  61   end function
  62
  63 end MODULE mytypes
  64
  65 program test_eq
  66    use mytypes
  67    implicit none
  68
  69    type(pvar) x, y
  70    integer :: i = 4
  71    real :: r = 2.0
  72    character(len = 4, kind =4) :: c = "abcd"
  73 ! Check that intrinsic use of .not. and == is not overridden.
  74    if (.not.(i == 2*int (r))) stop 1
  75    if (r == 1.0) stop 2
  76
  77 ! Test defined operator ==
  78    x = pvar('test 1', 100)
  79    y = pvar('test 1', 100)
  80    if (.not.(x == y)) stop 3
  81    y = pvar('test 2', 100)
  82    if (x == y) stop 4
  83    if (x == r) stop 5            ! class default gives .false.
  84    if (100 == x) stop 6          !       ditto
  85    if (.not.(x == 100)) stop 7   ! integer selector gives a%level == b
  86    if (i == "c") stop 8          ! type mismatch => calls star_eq
  87    if (c == "abcd") stop 9       ! kind mismatch => calls star_eq
  88
  89 ! Test defined operator .not.
  90    y = .not.x
  91    if (y%level .ne. -x%level) stop 11
  92    y = .not.i
  93    if (y%level .ne. 0 .and. trim(y%name) .ne. "noname") stop 12
  94    y = .not.r
  95    if (y%level .ne. -2 .and. trim(y%name) .ne. "real") stop 13
  96 end program test_eq
  97 ! { dg-final { scan-tree-dump-times "star_eq" 14 "original" } }
  98 ! { dg-final { scan-tree-dump-times "star_not" 11 "original" } }