[gfortran, patch] PR17711: distinguish between .EQ. and == etc.

Tobias Schlüter tobias.schlueter@physik.uni-muenchen.de
Wed Nov 22 22:35:00 GMT 2006


This is a rather straightforward solution to the problem of printing  
the right operator name for intrinsic comparison operators, when an  
error is issued.  The goal is achieved by keeping track of which  
operator the user used in the first place, they are distinguished by  
using INTRINSIC_EQ2 for ".EQ." versus INTRINSIC_EQ for "==" etc.

While I was at it I also fixed a few inconsistent error messages which  
made necessary a change to gfortran.dg/logical_comp.f90.

Built and tested on i686/darwin. Ok for trunk?

:ADDPATCH fortran:

         * gfortran.h (gfc_intrinsic_op): Add INTRINSIC_EQ2, INTRINSIC_NE2,
         INTRINSIC_GT2, INTRINSIC_GE2, INTRINSIC_LT2, INTRINSIC_LE2.
         * arith.c (eval_intrinsic, eval_intrinsic0): Likewise.
         (gfc_eq2, gfc_ne2, gfc_gt2, gfc_ge2, gfc_lt2, gfc_le2): New
         functions, dealing with new enum values.
         * arith.h: Add prototypes for new functions.
         * dump-parse-tree.c (gfc_show_expr): Account for new enum
         values.
         * expr.c (simplify_intrinsic_op, check_intrinsic_op): Likewise.
         * interface.c (check_operator_interface): Likewise.
         * match.c (intrinsic_operators): Distinguish FORTRAN 77 style
         operators from Fortran 90 style operators using new enum values.
         * matchexp.c (match_level_4):  Account for new enum values.
         * module.c (mio_expr): Likewise.
         * resolve.c (resolve_operator): Deal with new enum values, fix
         inconsistent error messages.
         * trans-expr.c (gfc_conv_expr_op):  Account for new enum
         values.

Diff for the old testcase:
Index: logical_comp.f90
===================================================================
--- logical_comp.f90    (revision 119090)
+++ logical_comp.f90    (working copy)
@@ -4,6 +4,6 @@

  program foo
    logical :: b
-  b = b .eq. b  ! { dg-error ".EQV. instead of .eq." }
-  b = b .ne. b  ! { dg-error ".NEQV. instead of .ne." }
+  b = b .eq. b  ! { dg-error "'.eqv.' instead of '.eq.'" }
+  b = b .ne. b  ! { dg-error "'.neqv.' instead of '.ne.'" }
  end program

----------------------------------------------------------------
This message was sent using IMP, the Internet Messaging Program.

-------------- next part --------------
Index: interface.c
===================================================================
--- interface.c	(revision 119090)
+++ interface.c	(working copy)
@@ -592,6 +592,8 @@
 
     case INTRINSIC_EQ:
     case INTRINSIC_NE:
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
       if (args == 1)
 	goto num_args;
 
@@ -605,6 +607,10 @@
     case INTRINSIC_LE:		/* complex numbers */
     case INTRINSIC_LT:
     case INTRINSIC_GT:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_GT2:
       if (args == 1)
 	goto num_args;
 
Index: trans-expr.c
===================================================================
--- trans-expr.c	(revision 119090)
+++ trans-expr.c	(working copy)
@@ -1057,6 +1057,7 @@
       /* EQV and NEQV only work on logicals, but since we represent them
          as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE.  */
     case INTRINSIC_EQ:
+    case INTRINSIC_EQ2:
     case INTRINSIC_EQV:
       code = EQ_EXPR;
       checkstring = 1;
@@ -1064,6 +1065,7 @@
       break;
 
     case INTRINSIC_NE:
+    case INTRINSIC_NE2:
     case INTRINSIC_NEQV:
       code = NE_EXPR;
       checkstring = 1;
@@ -1071,24 +1073,28 @@
       break;
 
     case INTRINSIC_GT:
+    case INTRINSIC_GT2:
       code = GT_EXPR;
       checkstring = 1;
       lop = 1;
       break;
 
     case INTRINSIC_GE:
+    case INTRINSIC_GE2:
       code = GE_EXPR;
       checkstring = 1;
       lop = 1;
       break;
 
     case INTRINSIC_LT:
+    case INTRINSIC_LT2:
       code = LT_EXPR;
       checkstring = 1;
       lop = 1;
       break;
 
     case INTRINSIC_LE:
+    case INTRINSIC_LE2:
       code = LE_EXPR;
       checkstring = 1;
       lop = 1;
Index: matchexp.c
===================================================================
--- matchexp.c	(revision 119090)
+++ matchexp.c	(working copy)
@@ -630,7 +630,9 @@
     }
 
   if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
-      && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT)
+      && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
+      && i != INTRINSIC_EQ2 && i != INTRINSIC_NE2 && i != INTRINSIC_GE2
+      && i != INTRINSIC_LE2 && i != INTRINSIC_LT2 && i != INTRINSIC_GT2)
     {
       gfc_current_locus = old_loc;
       *result = left;
@@ -674,6 +676,30 @@
       r = gfc_ge (left, right);
       break;
 
+    case INTRINSIC_EQ2:
+      r = gfc_eq2 (left, right);
+      break;
+
+    case INTRINSIC_NE2:
+      r = gfc_ne2 (left, right);
+      break;
+
+    case INTRINSIC_LT2:
+      r = gfc_lt2 (left, right);
+      break;
+
+    case INTRINSIC_LE2:
+      r = gfc_le2 (left, right);
+      break;
+
+    case INTRINSIC_GT2:
+      r = gfc_gt2 (left, right);
+      break;
+
+    case INTRINSIC_GE2:
+      r = gfc_ge2 (left, right);
+      break;
+
     default:
       gfc_internal_error ("match_level_4(): Bad operator");
     }
Index: dump-parse-tree.c
===================================================================
--- dump-parse-tree.c	(revision 119090)
+++ dump-parse-tree.c	(working copy)
@@ -463,21 +463,27 @@
 	  gfc_status ("NEQV ");
 	  break;
 	case INTRINSIC_EQ:
+	case INTRINSIC_EQ2:
 	  gfc_status ("= ");
 	  break;
 	case INTRINSIC_NE:
+	case INTRINSIC_NE2:
 	  gfc_status ("<> ");
 	  break;
 	case INTRINSIC_GT:
+	case INTRINSIC_GT2:
 	  gfc_status ("> ");
 	  break;
 	case INTRINSIC_GE:
+	case INTRINSIC_GE2:
 	  gfc_status (">= ");
 	  break;
 	case INTRINSIC_LT:
+	case INTRINSIC_LT2:
 	  gfc_status ("< ");
 	  break;
 	case INTRINSIC_LE:
+	case INTRINSIC_LE2:
 	  gfc_status ("<= ");
 	  break;
 	case INTRINSIC_NOT:
Index: gfortran.h
===================================================================
--- gfortran.h	(revision 119090)
+++ gfortran.h	(working copy)
@@ -187,8 +187,14 @@
   INTRINSIC_UMINUS, INTRINSIC_PLUS, INTRINSIC_MINUS, INTRINSIC_TIMES,
   INTRINSIC_DIVIDE, INTRINSIC_POWER, INTRINSIC_CONCAT,
   INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV,
+  /* ==, /=, >, >=, <, <=  */
   INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE,
-  INTRINSIC_LT, INTRINSIC_LE, INTRINSIC_NOT, INTRINSIC_USER,
+  INTRINSIC_LT, INTRINSIC_LE,
+  /* .EQ., .NE., .GT., .GE., .LT., .LE.  */
+  INTRINSIC_EQ2, INTRINSIC_NE2, INTRINSIC_GT2, INTRINSIC_GE2,
+  INTRINSIC_LT2, INTRINSIC_LE2,
+
+  INTRINSIC_NOT, INTRINSIC_USER,
   INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
   GFC_INTRINSIC_END /* Sentinel */
 }
Index: expr.c
===================================================================
--- expr.c	(revision 119090)
+++ expr.c	(working copy)
@@ -819,26 +819,50 @@
       result = gfc_eq (op1, op2);
       break;
 
+    case INTRINSIC_EQ2:
+      result = gfc_eq2 (op1, op2);
+      break;
+
     case INTRINSIC_NE:
       result = gfc_ne (op1, op2);
       break;
 
+    case INTRINSIC_NE2:
+      result = gfc_ne2 (op1, op2);
+      break;
+
     case INTRINSIC_GT:
       result = gfc_gt (op1, op2);
       break;
 
+    case INTRINSIC_GT2:
+      result = gfc_gt2 (op1, op2);
+      break;
+
     case INTRINSIC_GE:
       result = gfc_ge (op1, op2);
       break;
 
+    case INTRINSIC_GE2:
+      result = gfc_ge2 (op1, op2);
+      break;
+
     case INTRINSIC_LT:
       result = gfc_lt (op1, op2);
       break;
 
+    case INTRINSIC_LT2:
+      result = gfc_lt2 (op1, op2);
+      break;
+
     case INTRINSIC_LE:
       result = gfc_le (op1, op2);
       break;
 
+    case INTRINSIC_LE2:
+      result = gfc_le2 (op1, op2);
+      break;
+
     case INTRINSIC_NOT:
       result = gfc_not (op1);
       break;
@@ -1596,6 +1620,12 @@
     case INTRINSIC_GE:
     case INTRINSIC_LT:
     case INTRINSIC_LE:
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
+    case INTRINSIC_GT2:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_LE2:
       if ((*check_function) (op2) == FAILURE)
 	return FAILURE;
       
Index: module.c
===================================================================
--- module.c	(revision 119090)
+++ module.c	(working copy)
@@ -2617,6 +2617,12 @@
 	case INTRINSIC_GE:
 	case INTRINSIC_LT:
 	case INTRINSIC_LE:
+	case INTRINSIC_EQ2:
+	case INTRINSIC_NE2:
+	case INTRINSIC_GT2:
+	case INTRINSIC_GE2:
+	case INTRINSIC_LT2:
+	case INTRINSIC_LE2:
 	  mio_expr (&e->value.op.op1);
 	  mio_expr (&e->value.op.op2);
 	  break;
Index: resolve.c
===================================================================
--- resolve.c	(revision 119090)
+++ resolve.c	(working copy)
@@ -2045,7 +2045,7 @@
 	  break;
 	}
 
-      sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
+      sprintf (msg, _("Operand of '.not.' operator at %%L is %s"),
 	       gfc_typename (&op1->ts));
       goto bad_op;
 
@@ -2053,6 +2053,10 @@
     case INTRINSIC_GE:
     case INTRINSIC_LT:
     case INTRINSIC_LE:
+    case INTRINSIC_GT2:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_LE2:
       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
 	{
 	  strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
@@ -2063,6 +2067,8 @@
 
     case INTRINSIC_EQ:
     case INTRINSIC_NE:
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
 	{
 	  e->ts.type = BT_LOGICAL;
@@ -2081,8 +2087,9 @@
 
       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
 	sprintf (msg,
-	         _("Logicals at %%L must be compared with %s instead of %s"),
-		 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
+	         _("Logicals at %%L must be compared with '%s'"
+		   "instead of '%s'"),
+		 e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
 		 gfc_op2string (e->value.op.operator));
       else
 	sprintf (msg,
@@ -2132,7 +2139,12 @@
     case INTRINSIC_GE:
     case INTRINSIC_LT:
     case INTRINSIC_LE:
-
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
+    case INTRINSIC_GT2:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_LE2:
       if (op1->rank == 0 && op2->rank == 0)
 	e->rank = 0;
 
Index: match.c
===================================================================
--- match.c	(revision 119090)
+++ match.c	(working copy)
@@ -45,18 +45,18 @@
     minit (".or.", INTRINSIC_OR),
     minit (".eqv.", INTRINSIC_EQV),
     minit (".neqv.", INTRINSIC_NEQV),
-    minit (".eq.", INTRINSIC_EQ),
     minit ("==", INTRINSIC_EQ),
-    minit (".ne.", INTRINSIC_NE),
     minit ("/=", INTRINSIC_NE),
-    minit (".ge.", INTRINSIC_GE),
     minit (">=", INTRINSIC_GE),
-    minit (".le.", INTRINSIC_LE),
     minit ("<=", INTRINSIC_LE),
-    minit (".lt.", INTRINSIC_LT),
     minit ("<", INTRINSIC_LT),
-    minit (".gt.", INTRINSIC_GT),
     minit (">", INTRINSIC_GT),
+    minit (".eq.", INTRINSIC_EQ2),
+    minit (".ne.", INTRINSIC_NE2),
+    minit (".ge.", INTRINSIC_GE2),
+    minit (".le.", INTRINSIC_LE2),
+    minit (".lt.", INTRINSIC_LT2),
+    minit (".gt.", INTRINSIC_GT2),
     minit (".not.", INTRINSIC_NOT),
     minit ("parens", INTRINSIC_PARENTHESES),
     minit (NULL, INTRINSIC_NONE)
Index: arith.c
===================================================================
--- arith.c	(revision 119090)
+++ arith.c	(working copy)
@@ -1489,6 +1489,10 @@
     case INTRINSIC_LT:
     case INTRINSIC_LE:
     case INTRINSIC_GT:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_LE2:
+    case INTRINSIC_GT2:
       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
 	{
 	  temp.ts.type = BT_LOGICAL;
@@ -1499,6 +1503,8 @@
     /* Fall through  */
     case INTRINSIC_EQ:
     case INTRINSIC_NE:
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
 	{
 	  unary = 0;
@@ -1531,7 +1537,10 @@
 
       if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE
 	  || operator == INTRINSIC_GE || operator == INTRINSIC_GT
-	  || operator == INTRINSIC_LE || operator == INTRINSIC_LT)
+	  || operator == INTRINSIC_LE || operator == INTRINSIC_LT
+	  || operator == INTRINSIC_EQ2 || operator == INTRINSIC_NE2
+	  || operator == INTRINSIC_GE2 || operator == INTRINSIC_GT2
+	  || operator == INTRINSIC_LE2 || operator == INTRINSIC_LT2)
 	{
 	  temp.ts.type = BT_LOGICAL;
 	  temp.ts.kind = gfc_default_logical_kind;
@@ -1625,6 +1634,12 @@
     case INTRINSIC_GT:
     case INTRINSIC_EQ:
     case INTRINSIC_NE:
+    case INTRINSIC_GE2:
+    case INTRINSIC_LT2:
+    case INTRINSIC_LE2:
+    case INTRINSIC_GT2:
+    case INTRINSIC_EQ2:
+    case INTRINSIC_NE2:
       op->ts.type = BT_LOGICAL;
       op->ts.kind = gfc_default_logical_kind;
       break;
@@ -1846,7 +1861,48 @@
   return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
 }
 
+gfc_expr *
+gfc_eq2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_EQ2, gfc_arith_eq, op1, op2);
+}
 
+
+gfc_expr *
+gfc_ne2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_NE2, gfc_arith_ne, op1, op2);
+}
+
+
+gfc_expr *
+gfc_gt2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_GT2, gfc_arith_gt, op1, op2);
+}
+
+
+gfc_expr *
+gfc_ge2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_GE2, gfc_arith_ge, op1, op2);
+}
+
+
+gfc_expr *
+gfc_lt2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_LT2, gfc_arith_lt, op1, op2);
+}
+
+
+gfc_expr *
+gfc_le2 (gfc_expr * op1, gfc_expr * op2)
+{
+  return eval_intrinsic_f3 (INTRINSIC_LE2, gfc_arith_le, op1, op2);
+}
+
+
 /* Convert an integer string to an expression node.  */
 
 gfc_expr *
Index: arith.h
===================================================================
--- arith.h	(revision 119090)
+++ arith.h	(working copy)
@@ -62,6 +62,12 @@
 gfc_expr *gfc_ge (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_lt (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_le (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_eq2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_ne2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_gt2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_ge2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_lt2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_le2 (gfc_expr *, gfc_expr *);
 
 /* Convert strings to literal constants.  */
 gfc_expr *gfc_convert_integer (const char *, int, int, locus *);
-------------- next part --------------
A non-text attachment was scrubbed...
Name: comparison_1.f90
Type: text/x-fortran
Size: 804 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/gcc-patches/attachments/20061122/44c257fd/attachment.bin>


More information about the Gcc-patches mailing list