Hi Harald, I was overthinking the problem. The rejected cases led me to a fix that can only be described as a considerable simplification compared with the first patch!
The testcase now reflects the requirements of the standard and regtests without failures. OK for mainline? Thanks Paul Fortran: Defined operators with unlimited polymorphic args [PR98498] 2023-11-02 Paul Thomas <pa...@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. On Wed, 1 Nov 2023 at 20:12, Harald Anlauf <anl...@gmx.de> wrote: > Hi Paul, > > Am 01.11.23 um 19:02 schrieb Paul Richard Thomas: > > 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 logic is likely harder to parse with if/else than with > switch(op)/case. However, I do not think that the order of > the enum will ever be changed, as the module format relies > on that very order. > > > The testcase runs fine with both mainline and nagfor. I think that > > compile-only with counts of star-eq and star_not should suffice. > > I found other cases that are rejected even with your patch, > but which are accepted by nagfor. Example: > > print *, ('a' == c) > > Nagfor prints F at runtime as expected, as it correctly resolves > this to star_eq. Further examples can be easily constructed. > > Can you have a look? > > Thanks, > Harald > > > Regtests with no regressions. OK for mainline? > > > > Paul > > > > Fortran: Defined operators with unlimited polymorphic args [PR98498] > > > > 2023-11-01 Paul Thomas <pa...@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. > > > >
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 8c4571e0aa6..fc4fe662eab 100644 --- 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
! { 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 <pa...@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" } }