gcc/testsuite/gfortran.dg/overload_5.f90

   1 ! { dg-do run }
   2 ! PR fortran/109641
   3 !
   4 ! Check overloading of intrinsic binary operators for numeric operands
   5 ! Reported by Adelson Oliveira
   6
   7 MODULE TESTEOP
   8   IMPLICIT NONE
   9   INTERFACE OPERATOR(.MULT.)
  10     MODULE PROCEDURE MULTr4
  11     MODULE PROCEDURE MULTc4
  12   END INTERFACE
  13   INTERFACE OPERATOR(*)
  14     MODULE PROCEDURE MULTr4
  15     MODULE PROCEDURE MULTc4
  16   END INTERFACE
  17   INTERFACE OPERATOR(==)
  18     MODULE PROCEDURE MULTr4
  19     MODULE PROCEDURE MULTc4
  20     MODULE PROCEDURE MULTr8
  21   END INTERFACE
  22   INTERFACE OPERATOR(<)
  23     MODULE PROCEDURE MULTc4
  24     MODULE PROCEDURE MULTi4
  25   END INTERFACE
  26   INTERFACE OPERATOR(**)
  27     MODULE PROCEDURE MULTc4
  28     MODULE PROCEDURE MULTi4
  29   END INTERFACE
  30   interface copy
  31      MODULE PROCEDURE copy
  32   end interface copy
  33 CONTAINS
  34   elemental function copy (z)
  35     complex, intent(in) :: z
  36     complex             :: copy
  37     copy = z
  38   end function copy
  39   FUNCTION MULTr4(v,m)
  40     REAL,    INTENT(IN) :: v(:)
  41     REAL,    INTENT(IN) :: m(:,:)
  42     REAL                :: MULTr4(SIZE(m,DIM=1),SIZE(m,DIM=2))
  43     INTEGER             :: i
  44     FORALL(i=1:SIZE(v)) MULTr4(:,i)=m(:,i)*v(i)
  45   END FUNCTION MULTr4
  46   FUNCTION MULTr8(v,m)
  47     REAL,             INTENT(IN) :: v(:)
  48     double precision, INTENT(IN) :: m(:,:)
  49     double precision             :: MULTr8(SIZE(m,DIM=1),SIZE(m,DIM=2))
  50     INTEGER             :: i
  51     FORALL(i=1:SIZE(v)) MULTr8(:,i)=m(:,i)*v(i)
  52   END FUNCTION MULTr8
  53   FUNCTION MULTc4(v,m)
  54     REAL,    INTENT(IN) :: v(:)
  55     COMPLEX, INTENT(IN) :: m(:,:)
  56     COMPLEX             :: MULTc4(SIZE(m,DIM=1),SIZE(m,DIM=2))
  57     INTEGER             :: i
  58     FORALL(i=1:SIZE(v)) MULTc4(:,i)=m(:,i)*v(i)
  59   END FUNCTION MULTc4
  60   FUNCTION MULTi4(v,m)
  61     REAL,    INTENT(IN) :: v(:)
  62     integer, INTENT(IN) :: m(:,:)
  63     REAL                :: MULTi4(SIZE(m,DIM=1),SIZE(m,DIM=2))
  64     INTEGER             :: i
  65     FORALL(i=1:SIZE(v)) MULTi4(:,i)=m(:,i)*v(i)
  66   END FUNCTION MULTi4
  67 END MODULE TESTEOP
  68 PROGRAM TESTE
  69   USE TESTEOP
  70   implicit none
  71   type t
  72      complex :: c(3,3)
  73   end type t
  74   real,    parameter   :: vv(3)   = 42.
  75   complex, parameter   :: zz(3,3) = (1.0,0.0)
  76   integer, parameter   :: kk(3,3) = 2
  77   double precision     :: dd(3,3) = 3.d0
  78   COMPLEX, ALLOCATABLE :: m(:,:),r(:,:), s(:,:)
  79   REAL,    ALLOCATABLE :: v(:)
  80   type(t)              :: z(1) = t(zz)
  81   ALLOCATE(v(3),m(3,3),r(3,3),s(3,3))
  82   v = vv
  83   m = zz
  84   ! Original bug report
  85   r=v.MULT.m ! Reference
  86   s=v*m
  87   if (any (r /= s)) stop 1
  88   if (.not. all (r == s)) stop 2
  89   ! Check other binary intrinsics
  90   s=v==m
  91   if (any (r /= s)) stop 3
  92   s=v==copy(m)
  93   if (any (r /= s)) stop 4
  94   s=v==zz
  95   if (any (r /= s)) stop 5
  96   s=v==copy(zz)
  97   if (any (r /= s)) stop 6
  98   s=vv==m
  99   if (any (r /= s)) stop 7
 100   s=vv==copy(m)
 101   if (any (r /= s)) stop 8
 102   s=vv==zz
 103   if (any (r /= s)) stop 9
 104   s=vv==copy(zz)
 105   if (any (r /= s)) stop 10
 106   ! check if .eq. same operator as == etc.
 107   s=v.eq.m
 108   if (any (r /= s)) stop 11
 109   s=v.lt.z(1)%c
 110   if (any (r /= s)) stop 12
 111   s=v<((z(1)%c))
 112   if (any (r /= s)) stop 13
 113   if (.not. all (     1.   < (vv**kk))) stop 14
 114   if (.not. all (     1.   < (vv< kk))) stop 15
 115   if (.not. all ((42.,0.) == (v < m ))) stop 16
 116   if (.not. all ((42.,0.) == (v** m ))) stop 17
 117   if (.not. all ( 126.d0  == (vv==dd))) stop 18
 118 END PROGRAM TESTE