Fortran: Defined operators with unlimited polymorphic args [PR98498]

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

gcc/fortran
	PR fortran/98498
	* interface.cc (upoly_ok): Defined operators using unlimited
	polymorphic formal arguments must not override the intrinsic
	operator use.

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

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 8c4571e0aa6fe40eac53c237326ee01a44954cdf..fc4fe662eab191dfc1f4c87d7bb946c6c6983e02 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -4737,6 +4737,17 @@ gfc_extend_expr (gfc_expr *e)
          if (sym != NULL)
            break;
        }
+
+      /* F2018(15.4.3.4.2) requires that the use of unlimited polymorphic
+        formal arguments does not override the intrinsic uses.  */
+      gfc_push_suppress_errors ();
+      if (sym
+         && (UNLIMITED_POLY (sym->formal->sym)
+             || (sym->formal->next
+                 && UNLIMITED_POLY (sym->formal->next->sym)))
+         && !gfc_check_operator_interface (sym, e->value.op.op, e->where))
+       sym = NULL;
+      gfc_pop_suppress_errors ();
     }
 
   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are

diff --git a/gcc/testsuite/gfortran.dg/interface_50.f90 b/gcc/testsuite/gfortran.dg/interface_50.f90
new file mode 100644 (file)
index 0000000..2124548
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_50.f90
@@ -0,0 +1,98 @@
+! { 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
+   character(len = 4, kind =4) :: c = "abcd"
+! 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
+   if (i == "c") stop 8          ! type mismatch => calls star_eq
+   if (c == "abcd") stop 9       ! kind mismatch => calls star_eq
+
+! 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" 14 "original" } }
+! { dg-final { scan-tree-dump-times "star_not" 11 "original" } }