diff options
| -rw-r--r-- | gcc/fortran/decl.c | 11 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 122 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/operator_7.f90 | 27 |
4 files changed, 96 insertions, 65 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 8acd594..e97168f 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -6478,8 +6478,19 @@ access_attr_decl (gfc_statement st) case INTERFACE_INTRINSIC_OP: if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) { + gfc_intrinsic_op other_op; + gfc_current_ns->operator_access[op] = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + + /* Handle the case if there is another op with the same + function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ + other_op = gfc_equivalent_op (op); + + if (other_op != INTRINSIC_NONE) + gfc_current_ns->operator_access[other_op] = + (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + } else { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 752a071..72e412b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2816,6 +2816,7 @@ gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); int gfc_has_vector_subscript (gfc_expr*); +gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); /* io.c */ extern gfc_st_label format_asterisk; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 6575fbe..46f9d14 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1264,6 +1264,54 @@ check_uop_interfaces (gfc_user_op *uop) } } +/* Given an intrinsic op, return an equivalent op if one exists, + or INTRINSIC_NONE otherwise. */ + +gfc_intrinsic_op +gfc_equivalent_op (gfc_intrinsic_op op) +{ + switch(op) + { + case INTRINSIC_EQ: + return INTRINSIC_EQ_OS; + + case INTRINSIC_EQ_OS: + return INTRINSIC_EQ; + + case INTRINSIC_NE: + return INTRINSIC_NE_OS; + + case INTRINSIC_NE_OS: + return INTRINSIC_NE; + + case INTRINSIC_GT: + return INTRINSIC_GT_OS; + + case INTRINSIC_GT_OS: + return INTRINSIC_GT; + + case INTRINSIC_GE: + return INTRINSIC_GE_OS; + + case INTRINSIC_GE_OS: + return INTRINSIC_GE; + + case INTRINSIC_LT: + return INTRINSIC_LT_OS; + + case INTRINSIC_LT_OS: + return INTRINSIC_LT; + + case INTRINSIC_LE: + return INTRINSIC_LE_OS; + + case INTRINSIC_LE_OS: + return INTRINSIC_LE; + + default: + return INTRINSIC_NONE; + } +} /* For the namespace, check generic, user operator and intrinsic operator interfaces for consistency and to remove duplicate @@ -1304,75 +1352,19 @@ gfc_check_interfaces (gfc_namespace *ns) for (ns2 = ns; ns2; ns2 = ns2->parent) { + gfc_intrinsic_op other_op; + if (check_interface1 (ns->op[i], ns2->op[i], 0, interface_name, true)) goto done; - switch (i) - { - case INTRINSIC_EQ: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_EQ_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_NE: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_NE_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_GT: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_GT_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_GE: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_GE_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_LT: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_LT_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_LE: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS], - 0, interface_name, true)) goto done; - break; - - case INTRINSIC_LE_OS: - if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE], - 0, interface_name, true)) goto done; - break; - - default: - break; - } + /* i should be gfc_intrinsic_op, but has to be int with this cast + here for stupid C++ compatibility rules. */ + other_op = gfc_equivalent_op ((gfc_intrinsic_op) i); + if (other_op != INTRINSIC_NONE + && check_interface1 (ns->op[i], ns2->op[other_op], + 0, interface_name, true)) + goto done; } } diff --git a/gcc/testsuite/gfortran.dg/operator_7.f90 b/gcc/testsuite/gfortran.dg/operator_7.f90 new file mode 100644 index 0000000..66d8dd1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/operator_7.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! PR fortran/45786 - operators were not correctly marked as public +! if the alternative form was used. +! Test case contributed by Neil Carlson. +module foo_type + private + public :: foo, operator(==) + type :: foo + integer :: bar + end type + interface operator(.eq.) + module procedure eq_foo + end interface +contains + logical function eq_foo (a, b) + type(foo), intent(in) :: a, b + eq_foo = (a%bar == b%bar) + end function +end module + + subroutine use_it (a, b) + use foo_type + type(foo) :: a, b + print *, a == b +end subroutine + +! { dg-final { cleanup-modules "foo_type" } } |