2009-08-17 Daniel Kraft <d@domob.eu>

	PR fortran/37425
	* resolve.c (get_checked_tb_operator_target): New routine to do checks
	on type-bound operators in common between intrinsic and user operators.
	(resolve_typebound_intrinsic_op): Call it.
	(resolve_typebound_user_op): Ditto.

2009-08-17  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/typebound_operator_2.f03: Test for error with illegal
	NOPASS bindings as operators.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150856 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3abd3bb..10f95fb 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2009-08-17  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/37425
+       * resolve.c (get_checked_tb_operator_target): New routine to do checks
+       on type-bound operators in common between intrinsic and user operators.
+       (resolve_typebound_intrinsic_op): Call it.
+       (resolve_typebound_user_op): Ditto.
+
 2009-08-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/41075

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fb72b93..4f99aba 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8965,6 +8965,29 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
 }
 
 
+/* Retrieve the target-procedure of an operator binding and do some checks in
+   common for intrinsic and user-defined type-bound operators.  */
+
+static gfc_symbol*
+get_checked_tb_operator_target (gfc_tbp_generic* target, locus where)
+{
+  gfc_symbol* target_proc;
+
+  gcc_assert (target->specific && !target->specific->is_generic);
+  target_proc = target->specific->u.specific->n.sym;
+  gcc_assert (target_proc);
+
+  /* All operator bindings must have a passed-object dummy argument.  */
+  if (target->specific->nopass)
+    {
+      gfc_error ("Type-bound operator at %L can't be NOPASS", &where);
+      return NULL;
+    }
+
+  return target_proc;
+}
+
+
 /* Resolve a type-bound intrinsic operator.  */
 
 static gfc_try
@@ -8998,9 +9021,9 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
     {
       gfc_symbol* target_proc;
 
-      gcc_assert (target->specific && !target->specific->is_generic);
-      target_proc = target->specific->u.specific->n.sym;
-      gcc_assert (target_proc);
+      target_proc = get_checked_tb_operator_target (target, p->where);
+      if (!target_proc)
+       return FAILURE;
 
       if (!gfc_check_operator_interface (target_proc, op, p->where))
        return FAILURE;
@@ -9059,9 +9082,9 @@ resolve_typebound_user_op (gfc_symtree* stree)
     {
       gfc_symbol* target_proc;
 
-      gcc_assert (target->specific && !target->specific->is_generic);
-      target_proc = target->specific->u.specific->n.sym;
-      gcc_assert (target_proc);
+      target_proc = get_checked_tb_operator_target (target, stree->n.tb->where);
+      if (!target_proc)
+       goto error;
 
       if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
        goto error;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c8713f5..7c905d7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2009-08-17  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/37425
+       * gfortran.dg/typebound_operator_2.f03: Test for error with illegal
+       NOPASS bindings as operators.
+
 2009-08-17  Uros Bizjak  <ubizjak@gmail.com>
 
        * lib/target-supports.exp

diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03
index ccce3b5..67f467c 100644 (file)
--- a/gcc/testsuite/gfortran.dg/typebound_operator_2.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_2.f03
@@ -13,8 +13,8 @@ MODULE m
     PROCEDURE, PASS :: onearg
     PROCEDURE, PASS :: onearg_alt => onearg
     PROCEDURE, PASS :: onearg_alt2 => onearg
+    PROCEDURE, NOPASS :: nopassed => onearg
     PROCEDURE, PASS :: threearg
-    PROCEDURE, NOPASS :: noarg
     PROCEDURE, PASS :: sub
     PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" }
     PROCEDURE, PASS :: func
@@ -26,10 +26,15 @@ MODULE m
 
     GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" }
     GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" }
-    GENERIC :: OPERATOR(.UOPC.) => noarg ! { dg-error "at least one argument" }
+    ! We can't check for the 'at least one argument' error, because in this case
+    ! the procedure must be NOPASS and that other error is issued.  But of
+    ! course this should be alright.
 
     GENERIC :: OPERATOR(.UNARY.) => onearg_alt
     GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" }
+
+    GENERIC :: OPERATOR(.UNARYPRIME.) => nopassed ! { dg-error "can't be NOPASS" }
+    GENERIC :: OPERATOR(-) => nopassed ! { dg-error "can't be NOPASS" }
   END TYPE t
 
 CONTAINS
@@ -44,10 +49,6 @@ CONTAINS
     threearg = 42
   END FUNCTION threearg
 
-  INTEGER FUNCTION noarg ()
-    noarg = 42
-  END FUNCTION noarg
-
   LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" }
     CLASS(t), INTENT(OUT) :: me
     CLASS(t), INTENT(IN) :: b