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

+2007-03-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	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  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/30655

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;
 }
 
 

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;
 }

gcc/testsuite/ChangeLog

+2007-03-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/30877
+	* gfortran.dg/operator_1.f90: New test.
+	* gfortran.dg/operator_2.f90: New test.
+
 2007-03-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR libfortran/31196

gcc/testsuite/gfortran.dg/operator_1.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/operator_2.f90

+! { 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