[PATCH] Fortran: overloading of intrinsic binary operators [PR109641]

[PATCH] Fortran: overloading of intrinsic binary operators [PR109641]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 692 bytes --]

Dear all,

the attached patch is mostly self-explaining: we mishandled the
overloading of intrinsic binary operators in the case the actual
operands were of intrinsic numeric type and the ranks of the
operands were not conformable, i.e. both were of non-zero and
different ranks.  In that case the operators could be converted
to the same type before the correct user-defined operator was
resolved, leading to either rejects-valid or accepts-invalid
or wrong resolution (= wrong code).

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

The patch is actually very limited in impact, but the bug is
sort of annoying.  Would it be OK to backport to 13.2 after
some waiting?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr109641.diff --]
[-- Type: text/x-patch, Size: 8483 bytes --]

From 50c8d3d4adeed1e6666cf44216075d1fb53a3ef0 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 1 May 2023 18:01:25 +0200
Subject: [PATCH] Fortran: overloading of intrinsic binary operators [PR109641]

Fortran allows overloading of intrinsic operators also for operands of
numeric intrinsic types.  The intrinsic operator versions are used
according to the rules of F2018 table 10.2 and imply type conversion as
long as the operand ranks are conformable.  Otherwise no type conversion
shall be performed to allow the resolution of a matching user-defined
operator.

gcc/fortran/ChangeLog:

	PR fortran/109641
	* arith.cc (eval_intrinsic): Check conformability of ranks of operands
	for intrinsic binary operators before performing type conversions.
	* gfortran.h (gfc_op_rank_conformable): Add prototype.
	* resolve.cc (resolve_operator): Check conformability of ranks of
	operands for intrinsic binary operators before performing type
	conversions.
	(gfc_op_rank_conformable): New helper function to compare ranks of
	operands of binary operator.

gcc/testsuite/ChangeLog:

	PR fortran/109641
	* gfortran.dg/overload_5.f90: New test.
---
 gcc/fortran/arith.cc                     |   6 ++
 gcc/fortran/gfortran.h                   |   1 +
 gcc/fortran/resolve.cc                   |  39 ++++++++
 gcc/testsuite/gfortran.dg/overload_5.f90 | 118 +++++++++++++++++++++++
 4 files changed, 164 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/overload_5.f90

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index d1d814b3ae1..86d56406047 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -1663,6 +1663,12 @@ eval_intrinsic (gfc_intrinsic_op op,
       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
 	goto runtime;

+      /* Do not perform conversions if operands are not conformable as
+	 required for the binary intrinsic operators (F2018:10.1.5).
+	 Defer to a possibly overloading user-defined operator.  */
+      if (!gfc_op_rank_conformable (op1, op2))
+	    goto runtime;
+
       /* Insert any necessary type conversions to make the operands
 	 compatible.  */

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a15ff90e228..ac21e1813d9 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3730,6 +3730,7 @@ void gfc_free_association_list (gfc_association_list *);

 /* resolve.cc */
 void gfc_expression_rank (gfc_expr *);
+bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *);
 bool gfc_resolve_ref (gfc_expr *);
 bool gfc_resolve_expr (gfc_expr *);
 void gfc_resolve (gfc_namespace *);
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c3d508fb45d..341909d7de7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -4200,6 +4200,17 @@ resolve_operator (gfc_expr *e)
     case INTRINSIC_POWER:
       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
 	{
+	  /* Do not perform conversions if operands are not conformable as
+	     required for the binary intrinsic operators (F2018:10.1.5).
+	     Defer to a possibly overloading user-defined operator.  */
+	  if (!gfc_op_rank_conformable (op1, op2))
+	    {
+	      dual_locus_error = true;
+	      snprintf (msg, sizeof (msg),
+			_("Inconsistent ranks for operator at %%L and %%L"));
+	      goto bad_op;
+	    }
+
 	  gfc_type_convert_binary (e, 1);
 	  break;
 	}
@@ -4372,6 +4383,17 @@ resolve_operator (gfc_expr *e)

       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
 	{
+	  /* Do not perform conversions if operands are not conformable as
+	     required for the binary intrinsic operators (F2018:10.1.5).
+	     Defer to a possibly overloading user-defined operator.  */
+	  if (!gfc_op_rank_conformable (op1, op2))
+	    {
+	      dual_locus_error = true;
+	      snprintf (msg, sizeof (msg),
+			_("Inconsistent ranks for operator at %%L and %%L"));
+	      goto bad_op;
+	    }
+
 	  gfc_type_convert_binary (e, 1);

 	  e->ts.type = BT_LOGICAL;
@@ -5644,6 +5666,23 @@ done:
 }


+/* Given two expressions, check that their rank is conformable, i.e. either
+   both have the same rank or at least one is a scalar.  */
+
+bool
+gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
+{
+//  if (op1->expr_type == EXPR_VARIABLE && op1->ref)
+  if (op1->expr_type == EXPR_VARIABLE)
+    gfc_expression_rank (op1);
+//  if (op2->expr_type == EXPR_VARIABLE && op2->ref)
+  if (op2->expr_type == EXPR_VARIABLE)
+    gfc_expression_rank (op2);
+
+  return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
+}
+
+
 static void
 add_caf_get_intrinsic (gfc_expr *e)
 {
diff --git a/gcc/testsuite/gfortran.dg/overload_5.f90 b/gcc/testsuite/gfortran.dg/overload_5.f90
new file mode 100644
index 00000000000..f8c93af3518
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/overload_5.f90
@@ -0,0 +1,118 @@
+! { dg-do run }
+! PR fortran/109641
+!
+! Check overloading of intrinsic binary operators for numeric operands
+! Reported by Adelson Oliveira
+
+MODULE TESTEOP
+  IMPLICIT NONE
+  INTERFACE OPERATOR(.MULT.)
+    MODULE PROCEDURE MULTr4
+    MODULE PROCEDURE MULTc4
+  END INTERFACE
+  INTERFACE OPERATOR(*)
+    MODULE PROCEDURE MULTr4
+    MODULE PROCEDURE MULTc4
+  END INTERFACE
+  INTERFACE OPERATOR(==)
+    MODULE PROCEDURE MULTr4
+    MODULE PROCEDURE MULTc4
+    MODULE PROCEDURE MULTr8
+  END INTERFACE
+  INTERFACE OPERATOR(<)
+    MODULE PROCEDURE MULTc4
+    MODULE PROCEDURE MULTi4
+  END INTERFACE
+  INTERFACE OPERATOR(**)
+    MODULE PROCEDURE MULTc4
+    MODULE PROCEDURE MULTi4
+  END INTERFACE
+  interface copy
+     MODULE PROCEDURE copy
+  end interface copy
+CONTAINS
+  elemental function copy (z)
+    complex, intent(in) :: z
+    complex             :: copy
+    copy = z
+  end function copy
+  FUNCTION MULTr4(v,m)
+    REAL,    INTENT(IN) :: v(:)
+    REAL,    INTENT(IN) :: m(:,:)
+    REAL                :: MULTr4(SIZE(m,DIM=1),SIZE(m,DIM=2))
+    INTEGER             :: i
+    FORALL(i=1:SIZE(v)) MULTr4(:,i)=m(:,i)*v(i)
+  END FUNCTION MULTr4
+  FUNCTION MULTr8(v,m)
+    REAL,             INTENT(IN) :: v(:)
+    double precision, INTENT(IN) :: m(:,:)
+    double precision             :: MULTr8(SIZE(m,DIM=1),SIZE(m,DIM=2))
+    INTEGER             :: i
+    FORALL(i=1:SIZE(v)) MULTr8(:,i)=m(:,i)*v(i)
+  END FUNCTION MULTr8
+  FUNCTION MULTc4(v,m)
+    REAL,    INTENT(IN) :: v(:)
+    COMPLEX, INTENT(IN) :: m(:,:)
+    COMPLEX             :: MULTc4(SIZE(m,DIM=1),SIZE(m,DIM=2))
+    INTEGER             :: i
+    FORALL(i=1:SIZE(v)) MULTc4(:,i)=m(:,i)*v(i)
+  END FUNCTION MULTc4
+  FUNCTION MULTi4(v,m)
+    REAL,    INTENT(IN) :: v(:)
+    integer, INTENT(IN) :: m(:,:)
+    REAL                :: MULTi4(SIZE(m,DIM=1),SIZE(m,DIM=2))
+    INTEGER             :: i
+    FORALL(i=1:SIZE(v)) MULTi4(:,i)=m(:,i)*v(i)
+  END FUNCTION MULTi4
+END MODULE TESTEOP
+PROGRAM TESTE
+  USE TESTEOP
+  implicit none
+  type t
+     complex :: c(3,3)
+  end type t
+  real,    parameter   :: vv(3)   = 42.
+  complex, parameter   :: zz(3,3) = (1.0,0.0)
+  integer, parameter   :: kk(3,3) = 2
+  double precision     :: dd(3,3) = 3.d0
+  COMPLEX, ALLOCATABLE :: m(:,:),r(:,:), s(:,:)
+  REAL,    ALLOCATABLE :: v(:)
+  type(t)              :: z(1) = t(zz)
+  ALLOCATE(v(3),m(3,3),r(3,3),s(3,3))
+  v = vv
+  m = zz
+  ! Original bug report
+  r=v.MULT.m ! Reference
+  s=v*m
+  if (any (r /= s)) stop 1
+  if (.not. all (r == s)) stop 2
+  ! Check other binary intrinsics
+  s=v==m
+  if (any (r /= s)) stop 3
+  s=v==copy(m)
+  if (any (r /= s)) stop 4
+  s=v==zz
+  if (any (r /= s)) stop 5
+  s=v==copy(zz)
+  if (any (r /= s)) stop 6
+  s=vv==m
+  if (any (r /= s)) stop 7
+  s=vv==copy(m)
+  if (any (r /= s)) stop 8
+  s=vv==zz
+  if (any (r /= s)) stop 9
+  s=vv==copy(zz)
+  if (any (r /= s)) stop 10
+  ! check if .eq. same operator as == etc.
+  s=v.eq.m
+  if (any (r /= s)) stop 11
+  s=v.lt.z(1)%c
+  if (any (r /= s)) stop 12
+  s=v<((z(1)%c))
+  if (any (r /= s)) stop 13
+  if (.not. all (     1.   < (vv**kk))) stop 14
+  if (.not. all (     1.   < (vv< kk))) stop 15
+  if (.not. all ((42.,0.) == (v < m ))) stop 16
+  if (.not. all ((42.,0.) == (v** m ))) stop 17
+  if (.not. all ( 126.d0  == (vv==dd))) stop 18
+END PROGRAM TESTE
--
2.35.3

Re: [PATCH] Fortran: overloading of intrinsic binary operators [PR109641]

[Mikael Morin]

Hello,

Le 01/05/2023 à 18:29, Harald Anlauf via Fortran a écrit :
> Dear all,
> 
> the attached patch is mostly self-explaining: we mishandled the
> overloading of intrinsic binary operators in the case the actual
> operands were of intrinsic numeric type and the ranks of the
> operands were not conformable, i.e. both were of non-zero and
> different ranks.  In that case the operators could be converted
> to the same type before the correct user-defined operator was
> resolved, leading to either rejects-valid or accepts-invalid
> or wrong resolution (= wrong code).
> 
> Regtested on x86_64-pc-linux-gnu.  OK for mainline?
> 
> The patch is actually very limited in impact, but the bug is
> sort of annoying.  Would it be OK to backport to 13.2 after
> some waiting?
> 
> Thanks,
> Harald
(...)
> diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
> index c3d508fb45d..341909d7de7 100644
> --- a/gcc/fortran/resolve.cc
> +++ b/gcc/fortran/resolve.cc
> @@ -5644,6 +5666,23 @@ done:
>  }
> 
> 
> +/* Given two expressions, check that their rank is conformable, i.e. either
> +   both have the same rank or at least one is a scalar.  */
> +
> +bool
> +gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
> +{
> +//  if (op1->expr_type == EXPR_VARIABLE && op1->ref)
Please remove this, and the other one below.

> +  if (op1->expr_type == EXPR_VARIABLE)
> +    gfc_expression_rank (op1);
> +//  if (op2->expr_type == EXPR_VARIABLE && op2->ref)
> +  if (op2->expr_type == EXPR_VARIABLE)
> +    gfc_expression_rank (op2);
> +
> +  return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
> +}
> +
> +
>  static void
>  add_caf_get_intrinsic (gfc_expr *e)
>  {

The rest looks good.
OK for master, and backport as well.

Thanks
Mikael

Re: [PATCH] Fortran: overloading of intrinsic binary operators [PR109641]

[Harald Anlauf]

Hi Mikael,

On 5/5/23 13:43, Mikael Morin wrote:
> Hello,
>
> Le 01/05/2023 à 18:29, Harald Anlauf via Fortran a écrit :

>> +/* Given two expressions, check that their rank is conformable, i.e.
>> either
>> +   both have the same rank or at least one is a scalar.  */
>> +
>> +bool
>> +gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2)
>> +{
>> +//  if (op1->expr_type == EXPR_VARIABLE && op1->ref)
> Please remove this, and the other one below.

oops, that was a leftover from debugging sessions, which
I missed during my final pass.  Fixed and pushed as
r14-529-g185da7c2014ba41f38dd62cc719873ebf020b076.

Thanks for the review!

Harald

>> +  if (op1->expr_type == EXPR_VARIABLE)
>> +    gfc_expression_rank (op1);
>> +//  if (op2->expr_type == EXPR_VARIABLE && op2->ref)
>> +  if (op2->expr_type == EXPR_VARIABLE)
>> +    gfc_expression_rank (op2);
>> +
>> +  return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank);
>> +}
>> +
>> +
>>  static void
>>  add_caf_get_intrinsic (gfc_expr *e)
>>  {
>
> The rest looks good.
> OK for master, and backport as well.
>
> Thanks
> Mikael
>