re PR fortran/41951 ([OOP] Not diagnosing ambiguous operators (TB vs. INTERFACE))

2012-06-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41951
	PR fortran/49591
	* interface.c (check_new_interface): Rename, add 'loc' argument,
	make non-static.
	(gfc_add_interface): Rename 'check_new_interface'
	* gfortran.h (gfc_check_new_interface): Add prototype.
	* resolve.c (resolve_typebound_intrinsic_op): Add typebound operator
	targets to non-typebound operator list.

2012-06-27  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41951
	PR fortran/49591
	* gfortran.dg/typebound_operator_16.f03: New.

From-SVN: r189022

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a804e263ef2b7a599b6949b8cccfcad1a0f3410e..bbd0b50a9045390e5aef48046ab1791874d34135 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2012-06-27  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41951
+       PR fortran/49591
+       * interface.c (check_new_interface): Rename, add 'loc' argument,
+       make non-static.
+       (gfc_add_interface): Rename 'check_new_interface'
+       * gfortran.h (gfc_check_new_interface): Add prototype.
+       * resolve.c (resolve_typebound_intrinsic_op): Add typebound operator
+       targets to non-typebound operator list.
+
 2012-06-22  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/47710

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 43904e956a0ab6549583051f7b8327c0be6023a3..caa23bd6388d68b80caf0909fdd3dbd648216d6c 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2851,6 +2851,7 @@ gfc_symbol *gfc_search_interface (gfc_interface *, int,
 match gfc_extend_expr (gfc_expr *);
 void gfc_free_formal_arglist (gfc_formal_arglist *);
 gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *);
+gfc_try gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus);
 gfc_try gfc_add_interface (gfc_symbol *);
 gfc_interface *gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7a63f696f5457be2e672bcd77ea7a21b830ee91a..34e1ad7f88bc6c4b17547c6566752fc8e9fac6be 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3551,8 +3551,8 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
    the given interface list.  Ambiguity isn't checked yet since module
    procedures can be present without interfaces.  */
 
-static gfc_try
-check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
+gfc_try
+gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
 {
   gfc_interface *ip;
 
@@ -3560,8 +3560,8 @@ check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
     {
       if (ip->sym == new_sym)
        {
-         gfc_error ("Entity '%s' at %C is already present in the interface",
-                    new_sym->name);
+         gfc_error ("Entity '%s' at %L is already present in the interface",
+                    new_sym->name, &loc);
          return FAILURE;
        }
     }
@@ -3591,48 +3591,61 @@ gfc_add_interface (gfc_symbol *new_sym)
          {
            case INTRINSIC_EQ:
            case INTRINSIC_EQ_OS:
-             if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            case INTRINSIC_NE:
            case INTRINSIC_NE_OS:
-             if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            case INTRINSIC_GT:
            case INTRINSIC_GT_OS:
-             if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            case INTRINSIC_GE:
            case INTRINSIC_GE_OS:
-             if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            case INTRINSIC_LT:
            case INTRINSIC_LT_OS:
-             if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            case INTRINSIC_LE:
            case INTRINSIC_LE_OS:
-             if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
-                 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
+                                          gfc_current_locus) == FAILURE
+                 || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
+                                             gfc_current_locus) == FAILURE)
                return FAILURE;
              break;
 
            default:
-             if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
+             if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
+                                          gfc_current_locus) == FAILURE)
                return FAILURE;
          }
 
@@ -3646,7 +3659,8 @@ gfc_add_interface (gfc_symbol *new_sym)
          if (sym == NULL)
            continue;
 
-         if (check_new_interface (sym->generic, new_sym) == FAILURE)
+         if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
+             == FAILURE)
            return FAILURE;
        }
 
@@ -3654,8 +3668,8 @@ gfc_add_interface (gfc_symbol *new_sym)
       break;
 
     case INTERFACE_USER_OP:
-      if (check_new_interface (current_interface.uop->op, new_sym)
-         == FAILURE)
+      if (gfc_check_new_interface (current_interface.uop->op, new_sym,
+                                  gfc_current_locus) == FAILURE)
        return FAILURE;
 
       head = &current_interface.uop->op;

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4595f76c9a4ec72a806f1609008c296b9c63879f..0434e0804c7445eb4ba5d52851a7d58b8174fc3a 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11264,6 +11264,22 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
 
       if (!gfc_check_operator_interface (target_proc, op, p->where))
        goto error;
+
+      /* Add target to non-typebound operator list.  */
+      if (!target->specific->deferred && !derived->attr.use_assoc
+         && p->access != ACCESS_PRIVATE)
+       {
+         gfc_interface *head, *intr;
+         if (gfc_check_new_interface (derived->ns->op[op], target_proc,
+                                      p->where) == FAILURE)
+           return FAILURE;
+         head = derived->ns->op[op];
+         intr = gfc_get_interface ();
+         intr->sym = target_proc;
+         intr->where = p->where;
+         intr->next = head;
+         derived->ns->op[op] = intr;
+       }
     }
 
   return SUCCESS;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0c85963d358ff5255ecbdf0c8c2f2646e7d6779b..3f2a06fafe41076fe9780d1c16d2f7aa016a8fd3 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-06-27  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41951
+       PR fortran/49591
+       * gfortran.dg/typebound_operator_16.f03: New.
+
 2012-06-27  Jakub Jelinek  <jakub@redhat.com>
 
        * gcc.target/i386/sse4_1-pmuldq.c (TEST): Initialize

diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_16.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_16.f03
new file mode 100644 (file)
index 0000000..eff43eb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_16.f03
@@ -0,0 +1,49 @@
+! { dg-do compile }
+!
+! PR 49591: [OOP] Multiple identical specific procedures in type-bound operator not detected
+!
+! This is interpretation request F03/0018:
+! http://www.j3-fortran.org/doc/meeting/195/11-214.txt
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module M1
+  type T
+    integer x
+  contains
+    procedure :: MyAdd_t => myadd
+    generic :: operator(+) => myAdd_t
+  end type T
+  type X
+    real q
+  contains
+    procedure, pass(b) :: MyAdd_x => myadd
+    generic :: operator(+) => myAdd_x       ! { dg-error "is already present in the interface" }
+  end type X
+contains
+  integer function MyAdd ( A, B )
+    class(t), intent(in) :: A
+    class(x), intent(in) :: B
+    myadd = a%x + b%q
+  end function MyAdd
+end module
+
+module M2
+  interface operator(+)
+    procedure MyAdd
+  end interface
+  type T
+    integer x
+  contains
+    procedure :: MyAdd_t => myadd
+    generic :: operator(+) => myAdd_t  ! { dg-error "is already present in the interface" }
+  end type T
+contains
+  integer function MyAdd ( A, B )
+    class(t), intent(in) :: A
+    real, intent(in) :: B
+    myadd = a%x + b
+  end function MyAdd
+end module
+
+! { dg-final { cleanup-modules "M1 M2" } }