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 <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..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
! { 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 ! 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" } }