[gfortran, patch] PR17711: distinguish between .EQ. and == etc.
Tobias Schlüter
tobias.schlueter@physik.uni-muenchen.de
Thu Nov 23 10:03: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/fortran/attachments/20061123/44c257fd/attachment.bin>
More information about the Fortran
mailing list