re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators)

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.

From-SVN: r150856

gcc/fortran/ChangeLog

+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

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;

gcc/testsuite/ChangeLog

+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

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