From 271892929a448a2bad2fa83e5652958d1af3f1a4 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Sun, 25 Mar 2007 09:01:23 +0000 Subject: [PATCH] re PR fortran/30877 (Extending intrinsic operators) PR fortran/30877 * fortran/interface.c (check_operator_interface): Implement the standard checks on user operators extending intrinsic operators. * fortran/resolve.c (resolve_operator): If the ranks of operators don't match, don't error out but try the user-defined ones first. * gfortran.dg/operator_1.f90: New test. * gfortran.dg/operator_2.f90: New test. From-SVN: r123196 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/interface.c | 181 ++++++++++++++++++------------- gcc/fortran/resolve.c | 17 ++- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/operator_1.f90 | 69 ++++++++++++ gcc/testsuite/gfortran.dg/operator_2.f90 | 40 +++++++ 6 files changed, 239 insertions(+), 82 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/operator_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/operator_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d99b31f..460f211 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2007-03-25 Francois-Xavier Coudert + + PR fortran/30877 + * fortran/interface.c (check_operator_interface): Implement + the standard checks on user operators extending intrinsic operators. + * fortran/resolve.c (resolve_operator): If the ranks of operators + don't match, don't error out but try the user-defined ones first. + 2007-03-24 Francois-Xavier Coudert PR fortran/30655 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9ce42cc..1672b1c 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -493,7 +493,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator) sym_intent i1, i2; gfc_symbol *sym; bt t1, t2; - int args; + int args, r1, r2, k1, k2; if (intr == NULL) return; @@ -501,6 +501,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator) args = 0; t1 = t2 = BT_UNKNOWN; i1 = i2 = INTENT_UNKNOWN; + r1 = r2 = -1; + k1 = k2 = -1; for (formal = intr->sym->formal; formal; formal = formal->next) { @@ -515,20 +517,35 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator) { t1 = sym->ts.type; i1 = sym->attr.intent; + r1 = (sym->as != NULL) ? sym->as->rank : 0; + k1 = sym->ts.kind; } if (args == 1) { t2 = sym->ts.type; i2 = sym->attr.intent; + r2 = (sym->as != NULL) ? sym->as->rank : 0; + k2 = sym->ts.kind; } args++; } - if (args == 0 || args > 2) - goto num_args; - sym = intr->sym; + /* Only +, - and .not. can be unary operators. + .not. cannot be a binary operator. */ + if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS + && operator != INTRINSIC_MINUS + && operator != INTRINSIC_NOT) + || (args == 2 && operator == INTRINSIC_NOT)) + { + gfc_error ("Operator interface at %L has the wrong number of arguments", + &intr->where); + return; + } + + /* Check that intrinsics are mapped to functions, except + INTRINSIC_ASSIGN which should map to a subroutine. */ if (operator == INTRINSIC_ASSIGN) { if (!sym->attr.subroutine) @@ -564,114 +581,124 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator) } } - switch (operator) + /* Check intents on operator interfaces. */ + if (operator == INTRINSIC_ASSIGN) { - case INTRINSIC_PLUS: /* Numeric unary or binary */ - case INTRINSIC_MINUS: - if ((args == 1) - && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)) + if (i1 != INTENT_OUT && i1 != INTENT_INOUT) + gfc_error ("First argument of defined assignment at %L must be " + "INTENT(IN) or INTENT(INOUT)", &intr->where); + + if (i2 != INTENT_IN) + gfc_error ("Second argument of defined assignment at %L must be " + "INTENT(IN)", &intr->where); + } + else + { + if (i1 != INTENT_IN) + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &intr->where); + + if (args == 2 && i2 != INTENT_IN) + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &intr->where); + } + + /* From now on, all we have to do is check that the operator definition + doesn't conflict with an intrinsic operator. The rules for this + game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards, + as well as 12.3.2.1.1 of Fortran 2003: + + "If the operator is an intrinsic-operator (R310), the number of + function 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 (7.1.2)." */ + +#define IS_NUMERIC_TYPE(t) \ + ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX) + + /* Unary ops are easy, do them first. */ + if (operator == INTRINSIC_NOT) + { + if (t1 == BT_LOGICAL) goto bad_repl; + else + return; + } - if ((args == 2) - && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX) - && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX)) + if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS)) + { + if (IS_NUMERIC_TYPE (t1)) goto bad_repl; + else + return; + } - break; + /* Character intrinsic operators have same character kind, thus + operator definitions with operands of different character kinds + are always safe. */ + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) + return; - case INTRINSIC_POWER: /* Binary numeric */ - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: + /* Intrinsic operators always perform on arguments of same rank, + so different ranks is also always safe. (rank == 0) is an exception + to that, because all intrinsic operators are elemental. */ + if (r1 != r2 && r1 != 0 && r2 != 0) + return; + switch (operator) + { case INTRINSIC_EQ: case INTRINSIC_NE: - if (args == 1) - goto num_args; - - if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX) - && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX)) + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) goto bad_repl; + /* Fall through. */ + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2)) + goto bad_repl; break; - case INTRINSIC_GE: /* Binary numeric operators that do not support */ - case INTRINSIC_LE: /* complex numbers */ - case INTRINSIC_LT: case INTRINSIC_GT: - if (args == 1) - goto num_args; - + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; if ((t1 == BT_INTEGER || t1 == BT_REAL) && (t2 == BT_INTEGER || t2 == BT_REAL)) goto bad_repl; + break; + case INTRINSIC_CONCAT: + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; break; - case INTRINSIC_OR: /* Binary logical */ case INTRINSIC_AND: + case INTRINSIC_OR: case INTRINSIC_EQV: case INTRINSIC_NEQV: - if (args == 1) - goto num_args; if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) goto bad_repl; break; - case INTRINSIC_NOT: /* Unary logical */ - if (args != 1) - goto num_args; - if (t1 == BT_LOGICAL) - goto bad_repl; - break; - - case INTRINSIC_CONCAT: /* Binary string */ - if (args != 2) - goto num_args; - if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) - goto bad_repl; - break; - - case INTRINSIC_ASSIGN: /* Class by itself */ - if (args != 2) - goto num_args; - break; default: - gfc_internal_error ("check_operator_interface(): Bad operator"); - } - - /* Check intents on operator interfaces. */ - if (operator == INTRINSIC_ASSIGN) - { - if (i1 != INTENT_OUT && i1 != INTENT_INOUT) - gfc_error ("First argument of defined assignment at %L must be " - "INTENT(IN) or INTENT(INOUT)", &intr->where); - - if (i2 != INTENT_IN) - gfc_error ("Second argument of defined assignment at %L must be " - "INTENT(IN)", &intr->where); - } - else - { - if (i1 != INTENT_IN) - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &intr->where); - - if (args == 2 && i2 != INTENT_IN) - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &intr->where); - } + break; + } return; +#undef IS_NUMERIC_TYPE + bad_repl: gfc_error ("Operator interface at %L conflicts with intrinsic interface", &intr->where); return; - -num_args: - gfc_error ("Operator interface at %L has the wrong number of arguments", - &intr->where); - return; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 164a0cb..03e6360 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2082,6 +2082,7 @@ resolve_operator (gfc_expr *e) { gfc_expr *op1, *op2; char msg[200]; + bool dual_locus_error; try t; /* Resolve all subnodes-- give them types. */ @@ -2107,6 +2108,7 @@ resolve_operator (gfc_expr *e) op1 = e->value.op.op1; op2 = e->value.op.op2; + dual_locus_error = false; switch (e->value.op.operator) { @@ -2306,12 +2308,14 @@ resolve_operator (gfc_expr *e) } else { - gfc_error ("Inconsistent ranks for operator at %L and %L", - &op1->where, &op2->where); - t = FAILURE; - /* Allow higher level expressions to work. */ e->rank = 0; + + /* Try user-defined operators, and otherwise throw an error. */ + dual_locus_error = true; + sprintf (msg, + _("Inconsistent ranks for operator at %%L and %%L")); + goto bad_op; } } @@ -2350,7 +2354,10 @@ bad_op: if (gfc_extend_expr (e) == SUCCESS) return SUCCESS; - gfc_error (msg, &e->where); + if (dual_locus_error) + gfc_error (msg, &op1->where, &op2->where); + else + gfc_error (msg, &e->where); return FAILURE; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8f31532..8bd087a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-03-25 Francois-Xavier Coudert + + PR fortran/30877 + * gfortran.dg/operator_1.f90: New test. + * gfortran.dg/operator_2.f90: New test. + 2007-03-25 Thomas Koenig PR libfortran/31196 diff --git a/gcc/testsuite/gfortran.dg/operator_1.f90 b/gcc/testsuite/gfortran.dg/operator_1.f90 new file mode 100644 index 0000000..1800b68 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/operator_1.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! Test the extension of intrinsic operators +module m1 + interface operator(*) + module procedure f1 + module procedure f2 + module procedure f3 + end interface + + interface operator(.or.) + module procedure g1 + end interface + + interface operator(//) + module procedure g1 + end interface + +contains + + function f1(a,b) result (c) + integer, dimension(2,2), intent(in) :: a + integer, dimension(2), intent(in) :: b + integer, dimension(2) :: c + c = matmul(a,b) + end function f1 + function f2(a,b) result (c) + real, dimension(2,2), intent(in) :: a + real, dimension(2), intent(in) :: b + real, dimension(2) :: c + c = matmul(a,b) + end function f2 + function f3(a,b) result (c) + complex, dimension(2,2), intent(in) :: a + complex, dimension(2), intent(in) :: b + complex, dimension(2) :: c + c = matmul(a,b) + end function f3 + + elemental function g1(a,b) result (c) + integer, intent(in) :: a, b + integer :: c + c = a + b + end function g1 + +end module m1 + + use m1 + implicit none + + integer, dimension(2,2) :: ai + integer, dimension(2) :: bi, ci + real, dimension(2,2) :: ar + real, dimension(2) :: br, cr + complex, dimension(2,2) :: ac + complex, dimension(2) :: bc, cc + + ai = reshape((/-2,-4,7,8/),(/2,2/)) ; bi = 3 + if (any((ai*bi) /= matmul(ai,bi))) call abort() + if (any((ai .or. ai) /= ai+ai)) call abort() + if (any((ai // ai) /= ai+ai)) call abort() + + ar = reshape((/-2,-4,7,8/),(/2,2/)) ; br = 3 + if (any((ar*br) /= matmul(ar,br))) call abort() + + ac = reshape((/-2,-4,7,8/),(/2,2/)) ; bc = 3 + if (any((ac*bc) /= matmul(ac,bc))) call abort() + +end +! { dg-final { cleanup-modules "m1" } } diff --git a/gcc/testsuite/gfortran.dg/operator_2.f90 b/gcc/testsuite/gfortran.dg/operator_2.f90 new file mode 100644 index 0000000..11540ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/operator_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Test that we can't override intrinsic operators in invalid ways +module foo + + interface operator(*) + module procedure f1 ! { dg-error "conflicts with intrinsic interface" } + end interface + + interface operator(>) + module procedure f2 ! { dg-error "conflicts with intrinsic interface" } + end interface + + interface operator(/) + module procedure f3 + end interface + +contains + + function f1(a,b) result (c) + integer, intent(in) :: a + integer, dimension(:), intent(in) :: b + integer, dimension(size(b,1)) :: c + c = 0 + end function f1 + + function f2(a,b) + character(len=*), intent(in) :: a + character(len=*), intent(in) :: b + logical :: f2 + f2 = .false. + end function f2 + + function f3(a,b) result (c) + integer, dimension(:,:), intent(in) :: a + integer, dimension(:), intent(in) :: b + integer, dimension(size(b,1)) :: c + c = 0 + end function f3 + +end -- 2.7.4