[Patch, fortran] PR98498 - Interp request: defined operators and unlimited polymorphic

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 940 bytes --]

The interpretation request came in a long time ago but I only just got
around to implementing it.

The updated text from the standard is in the comment. Now I am writing
this, I think that I should perhaps use switch(op)/case rather than using
if/else if and depending on the order of the gfc_intrinsic_op enum being
maintained. Thoughts?

The testcase runs fine with both mainline and nagfor. I think that
compile-only with counts of star-eq and star_not should suffice.

Regtests with no regressions. OK for mainline?

Paul

Fortran: Defined operators with unlimited polymorphic args [PR98498]

2023-11-01  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/98498
* interface.cc (upoly_ok): New function.
(gfc_extend_expr): Use new function to ensure that defined
operators using unlimited polymorphic formal arguments do not
override their intrinsic uses.

gcc/testsuite/
PR fortran/98498
* gfortran.dg/interface_50.f90: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 2384 bytes --]

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 8c4571e0aa6..ba7fb5dfea5 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -4616,6 +4616,35 @@ build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
 }
 
 
+/* Check if the type of an actual argument is OK to use with an
+   unlimited polymorphic formal argument in a defined operation.  */
+
+static bool
+upoly_ok (bt type, gfc_intrinsic_op op)
+{
+  bool ok = false;
+  if (type == BT_DERIVED || type == BT_CLASS)
+    ok = true;
+  else if ((op >= INTRINSIC_UPLUS && op <= INTRINSIC_POWER)
+	   && (type == BT_LOGICAL || type == BT_CHARACTER))
+    ok = true;
+  else if ((op == INTRINSIC_CONCAT) && (type != BT_CHARACTER))
+    ok = true;
+  else if ((op >= INTRINSIC_GT && op <= INTRINSIC_LE)
+	   && (type == BT_COMPLEX))
+    ok = true;
+  else if ((op >= INTRINSIC_GT_OS) && (op <= INTRINSIC_LE_OS)
+	   && (type == BT_COMPLEX))
+    ok = true;
+  else if ((op >= INTRINSIC_AND) && (op <= INTRINSIC_NEQV)
+	   && (type != BT_LOGICAL))
+    ok = true;
+  else if ((op == INTRINSIC_NOT) && (type != BT_LOGICAL))
+    ok = true;
+  return ok;
+}
+
+
 /* This subroutine is called when an expression is being resolved.
    The expression node in question is either a user defined operator
    or an intrinsic operator with arguments that aren't compatible
@@ -4737,6 +4766,24 @@ gfc_extend_expr (gfc_expr *e)
 	  if (sym != NULL)
 	    break;
 	}
+
+      /* F2018(15.4.3.4.2): "If the operator is an intrinsic-operator (R608),
+	 the number of dummy arguments shall be consistent with the intrinsic
+	 uses of that operator, and the types, kind type parameters, or ranks
+	 of the dummy arguments shall differ from those required for the
+	 intrinsic operation (10.1.5)." ie. the use of unlimited polymorphic
+	 formal arguments must not override the intrinsic uses.  */
+      if (sym && (UNLIMITED_POLY (sym->formal->sym)
+		  || (sym->formal->next
+		      && UNLIMITED_POLY (sym->formal->next->sym))))
+	{
+	  bool arg2 = (actual->next != NULL);
+	  bool a1ok = upoly_ok (actual->expr->ts.type, e->value.op.op);
+	  bool a2ok = arg2 && upoly_ok (actual->next->expr->ts.type,
+					e->value.op.op);
+	  if ((!arg2 && !a1ok) || (arg2 && (!a1ok && !a2ok)))
+	    sym = NULL;
+	}
     }
 
   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are

[-- Attachment #3: interface_50.f90 --]
[-- Type: text/x-fortran, Size: 2419 bytes --]

! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! Tests the fix for PR98498, which was subject to an interpretation request
! as to whether or not the interface operator overrode the intrinsic use.
! (See PR for correspondence)
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
MODULE mytypes
  IMPLICIT none

  TYPE pvar
     character(len=20) :: name
     integer           :: level
  end TYPE pvar

  interface operator (==)
     module procedure star_eq
  end interface

  interface operator (.not.)
     module procedure star_not
  end interface

contains
  function star_eq(a, b)
    implicit none
    class(*), intent(in) :: a, b
    logical :: star_eq
    select type (a)
      type is (pvar)
      select type (b)
        type is (pvar)
          if((a%level .eq. b%level) .and. (a%name .eq. b%name)) then
            star_eq = .true.
          else
            star_eq = .false.
          end if
        type is (integer)
          star_eq = (a%level == b)
      end select
      class default
        star_eq = .false.
    end select
  end function star_eq

  function star_not (a)
    implicit none
    class(*), intent(in) :: a
    type(pvar) :: star_not
    select type (a)
      type is (pvar)
        star_not = a
        star_not%level = -star_not%level
      type is (real)
        star_not = pvar ("real", -int(a))
      class default
        star_not = pvar ("noname", 0)
    end select
  end function

end MODULE mytypes

program test_eq
   use mytypes
   implicit none

   type(pvar) x, y
   integer :: i = 4
   real :: r = 2.0
! Check that intrinsic use of .not. and == is not overridden.
   if (.not.(i == 2*int (r))) stop 1
   if (r == 1.0) stop 2

! Test defined operator ==
   x = pvar('test 1', 100)
   y = pvar('test 1', 100)
   if (.not.(x == y)) stop 3
   y = pvar('test 2', 100)
   if (x == y) stop 4
   if (x == r) stop 5            ! class default gives .false.
   if (100 == x) stop 6          !       ditto
   if (.not.(x == 100)) stop 7   ! integer selector gives a%level == b

! Test defined operator .not.
   y = .not.x
   if (y%level .ne. -x%level) stop 11
   y = .not.i
   if (y%level .ne. 0 .and. trim(y%name) .ne. "noname") stop 12
   y = .not.r
   if (y%level .ne. -2 .and. trim(y%name) .ne. "real") stop 13
end program test_eq
! { dg-final { scan-tree-dump-times "star_eq" 12 "original" } }
! { dg-final { scan-tree-dump-times "star_not" 11 "original" } }