re PR fortran/17711 (Wrong operator name in error message)

gcc/fortran:
2007-07-08  Daniel Franke  <franke.daniel@gmail.com>
	    Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/17711
	* gfortran.h (gfc_intrinsic_op): Added INTRINSIC_EQ_OS,
	INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS, 
	INTRINSIC_LT_OS and INTRINSIC_LE_OS.
	* arith.c (eval_intrinsic, eval_type_intrinsic0): Likewise.
	* arith.h (gfc_eq, gfc_ne, gfc_gt, gfc_ge, gfc_lt, gfc_le):
	Added gfc_intrinsic_op as third argument type.
	* 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.
	(gfc_check_interfaces): Added cross-checks for FORTRAN 77 and 
	Fortran 90 style operators using new enum values.
	(gfc_extend_expr): Likewise.
	(gfc_add_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.

gcc/testsuite:
2007-07-08  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/17711
	* gfortran.dg/operator_4.f90: New test.
	* gfortran.dg/operator_5.f90: New test.
	* gfortran.dg/logical_comp.f90: Adjusted error messages.
	* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.


Co-Authored-By: Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>

From-SVN: r126468
This commit is contained in:
Daniel Franke 2007-07-08 17:08:52 -04:00 committed by Daniel Franke
parent 376397285d
commit 3bed9dd023
17 changed files with 515 additions and 62 deletions

View File

@ -1,3 +1,28 @@
2007-07-08 Daniel Franke <franke.daniel@gmail.com>
Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/17711
* gfortran.h (gfc_intrinsic_op): Added INTRINSIC_EQ_OS,
INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS and INTRINSIC_LE_OS.
* arith.c (eval_intrinsic, eval_type_intrinsic0): Likewise.
* arith.h (gfc_eq, gfc_ne, gfc_gt, gfc_ge, gfc_lt, gfc_le):
Added gfc_intrinsic_op as third argument type.
* 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.
(gfc_check_interfaces): Added cross-checks for FORTRAN 77 and
Fortran 90 style operators using new enum values.
(gfc_extend_expr): Likewise.
(gfc_add_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.
2007-07-08 Tobias Burnus <burnus@net-b.de>
PR fortran/32669

View File

@ -1539,9 +1539,13 @@ eval_intrinsic (gfc_intrinsic_op operator,
/* Additional restrictions for ordering relations. */
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
temp.ts.type = BT_LOGICAL;
@ -1551,7 +1555,9 @@ eval_intrinsic (gfc_intrinsic_op operator,
/* Fall through */
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
unary = 0;
@ -1584,7 +1590,10 @@ eval_intrinsic (gfc_intrinsic_op operator,
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_EQ_OS || operator == INTRINSIC_NE_OS
|| operator == INTRINSIC_GE_OS || operator == INTRINSIC_GT_OS
|| operator == INTRINSIC_LE_OS || operator == INTRINSIC_LT_OS)
{
temp.ts.type = BT_LOGICAL;
temp.ts.kind = gfc_default_logical_kind;
@ -1668,11 +1677,17 @@ eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op)
switch (operator)
{
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
op->ts.type = BT_LOGICAL;
op->ts.kind = gfc_default_logical_kind;
break;
@ -1861,44 +1876,44 @@ gfc_neqv (gfc_expr *op1, gfc_expr *op2)
gfc_expr *
gfc_eq (gfc_expr *op1, gfc_expr *op2)
gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
}
gfc_expr *
gfc_ne (gfc_expr *op1, gfc_expr *op2)
gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
}
gfc_expr *
gfc_gt (gfc_expr *op1, gfc_expr *op2)
gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
}
gfc_expr *
gfc_ge (gfc_expr *op1, gfc_expr *op2)
gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
}
gfc_expr *
gfc_lt (gfc_expr *op1, gfc_expr *op2)
gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
}
gfc_expr *
gfc_le (gfc_expr *op1, gfc_expr *op2)
gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
{
return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2);
return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
}

View File

@ -57,12 +57,12 @@ gfc_expr *gfc_or (gfc_expr *, gfc_expr *);
gfc_expr *gfc_not (gfc_expr *);
gfc_expr *gfc_eqv (gfc_expr *, gfc_expr *);
gfc_expr *gfc_neqv (gfc_expr *, gfc_expr *);
gfc_expr *gfc_eq (gfc_expr *, gfc_expr *);
gfc_expr *gfc_ne (gfc_expr *, gfc_expr *);
gfc_expr *gfc_gt (gfc_expr *, gfc_expr *);
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_eq (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_ne (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_gt (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_ge (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_lt (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
/* Convert strings to literal constants. */
gfc_expr *gfc_convert_integer (const char *, int, int, locus *);

View File

@ -472,21 +472,27 @@ gfc_show_expr (gfc_expr *p)
gfc_status ("NEQV ");
break;
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
gfc_status ("= ");
break;
case INTRINSIC_NE:
gfc_status ("<> ");
case INTRINSIC_NE_OS:
gfc_status ("/= ");
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
gfc_status ("> ");
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
gfc_status (">= ");
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
gfc_status ("< ");
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
gfc_status ("<= ");
break;
case INTRINSIC_NOT:

View File

@ -766,6 +766,7 @@ gfc_is_constant_expr (gfc_expr *e)
static try
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_intrinsic_op op;
gfc_expr *op1, *op2, *result;
if (p->value.op.operator == INTRINSIC_USER)
@ -773,6 +774,7 @@ simplify_intrinsic_op (gfc_expr *p, int type)
op1 = p->value.op.op1;
op2 = p->value.op.op2;
op = p->value.op.operator;
if (gfc_simplify_expr (op1, type) == FAILURE)
return FAILURE;
@ -787,7 +789,7 @@ simplify_intrinsic_op (gfc_expr *p, int type)
p->value.op.op1 = NULL;
p->value.op.op2 = NULL;
switch (p->value.op.operator)
switch (op)
{
case INTRINSIC_PARENTHESES:
result = gfc_parentheses (op1);
@ -826,27 +828,33 @@ simplify_intrinsic_op (gfc_expr *p, int type)
break;
case INTRINSIC_EQ:
result = gfc_eq (op1, op2);
case INTRINSIC_EQ_OS:
result = gfc_eq (op1, op2, op);
break;
case INTRINSIC_NE:
result = gfc_ne (op1, op2);
case INTRINSIC_NE_OS:
result = gfc_ne (op1, op2, op);
break;
case INTRINSIC_GT:
result = gfc_gt (op1, op2);
case INTRINSIC_GT_OS:
result = gfc_gt (op1, op2, op);
break;
case INTRINSIC_GE:
result = gfc_ge (op1, op2);
case INTRINSIC_GE_OS:
result = gfc_ge (op1, op2, op);
break;
case INTRINSIC_LT:
result = gfc_lt (op1, op2);
case INTRINSIC_LT_OS:
result = gfc_lt (op1, op2, op);
break;
case INTRINSIC_LE:
result = gfc_le (op1, op2);
case INTRINSIC_LE_OS:
result = gfc_le (op1, op2, op);
break;
case INTRINSIC_NOT:
@ -1731,11 +1739,17 @@ check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
break;
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if ((*check_function) (op2) == FAILURE)
return FAILURE;

View File

@ -198,10 +198,14 @@ typedef enum
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_ASSIGN, INTRINSIC_PARENTHESES,
GFC_INTRINSIC_END /* Sentinel */
INTRINSIC_LT, INTRINSIC_LE,
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
}
gfc_intrinsic_op;

View File

@ -659,7 +659,9 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
switch (operator)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
/* Fall through. */
@ -674,9 +676,13 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
if ((t1 == BT_INTEGER || t1 == BT_REAL)
@ -1124,12 +1130,81 @@ gfc_check_interfaces (gfc_namespace *ns)
check_operator_interface (ns->operator[i], i);
for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
for (ns2 = ns; ns2; ns2 = ns2->parent)
{
if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
interface_name, true))
goto done;
switch (i)
{
case INTRINSIC_EQ:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_EQ_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
0, interface_name, true)) goto done;
break;
case INTRINSIC_NE:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_NE_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GT:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GT_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GE:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GE_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LT:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LT_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LE:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LE_OS:
if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
0, interface_name, true)) goto done;
break;
default:
break;
}
}
}
done:
gfc_current_ns = old_ns;
}
@ -2199,7 +2274,56 @@ gfc_extend_expr (gfc_expr *e)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
/* Due to the distinction between '==' and '.eq.' and friends, one has
to check if either is defined. */
switch (i)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
break;
default:
sym = gfc_search_interface (ns->operator[i], 0, &actual);
}
if (sym != NULL)
break;
}
@ -2330,9 +2454,54 @@ gfc_add_interface (gfc_symbol *new)
case INTERFACE_INTRINSIC_OP:
for (ns = current_interface.ns; ns; ns = ns->parent)
if (check_new_interface (ns->operator[current_interface.op], new)
== FAILURE)
switch (current_interface.op)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
return FAILURE;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
return FAILURE;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
return FAILURE;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
return FAILURE;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
return FAILURE;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
return FAILURE;
break;
default:
if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
return FAILURE;
}
head = &current_interface.ns->operator[current_interface.op];
break;

View File

@ -44,17 +44,17 @@ mstring intrinsic_operators[] = {
minit (".or.", INTRINSIC_OR),
minit (".eqv.", INTRINSIC_EQV),
minit (".neqv.", INTRINSIC_NEQV),
minit (".eq.", INTRINSIC_EQ),
minit (".eq.", INTRINSIC_EQ_OS),
minit ("==", INTRINSIC_EQ),
minit (".ne.", INTRINSIC_NE),
minit (".ne.", INTRINSIC_NE_OS),
minit ("/=", INTRINSIC_NE),
minit (".ge.", INTRINSIC_GE),
minit (".ge.", INTRINSIC_GE_OS),
minit (">=", INTRINSIC_GE),
minit (".le.", INTRINSIC_LE),
minit (".le.", INTRINSIC_LE_OS),
minit ("<=", INTRINSIC_LE),
minit (".lt.", INTRINSIC_LT),
minit (".lt.", INTRINSIC_LT_OS),
minit ("<", INTRINSIC_LT),
minit (".gt.", INTRINSIC_GT),
minit (".gt.", INTRINSIC_GT_OS),
minit (">", INTRINSIC_GT),
minit (".not.", INTRINSIC_NOT),
minit ("parens", INTRINSIC_PARENTHESES),

View File

@ -628,7 +628,9 @@ match_level_4 (gfc_expr **result)
}
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_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
&& i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
{
gfc_current_locus = old_loc;
*result = left;
@ -649,27 +651,33 @@ match_level_4 (gfc_expr **result)
switch (i)
{
case INTRINSIC_EQ:
r = gfc_eq (left, right);
case INTRINSIC_EQ_OS:
r = gfc_eq (left, right, i);
break;
case INTRINSIC_NE:
r = gfc_ne (left, right);
case INTRINSIC_NE_OS:
r = gfc_ne (left, right, i);
break;
case INTRINSIC_LT:
r = gfc_lt (left, right);
case INTRINSIC_LT_OS:
r = gfc_lt (left, right, i);
break;
case INTRINSIC_LE:
r = gfc_le (left, right);
case INTRINSIC_LE_OS:
r = gfc_le (left, right, i);
break;
case INTRINSIC_GT:
r = gfc_gt (left, right);
case INTRINSIC_GT_OS:
r = gfc_gt (left, right, i);
break;
case INTRINSIC_GE:
r = gfc_ge (left, right);
case INTRINSIC_GE_OS:
r = gfc_ge (left, right, i);
break;
default:

View File

@ -2610,12 +2610,18 @@ static const mstring intrinsics[] =
minit ("OR", INTRINSIC_OR),
minit ("EQV", INTRINSIC_EQV),
minit ("NEQV", INTRINSIC_NEQV),
minit ("EQ", INTRINSIC_EQ),
minit ("NE", INTRINSIC_NE),
minit ("GT", INTRINSIC_GT),
minit ("GE", INTRINSIC_GE),
minit ("LT", INTRINSIC_LT),
minit ("LE", INTRINSIC_LE),
minit ("==", INTRINSIC_EQ),
minit ("EQ", INTRINSIC_EQ_OS),
minit ("/=", INTRINSIC_NE),
minit ("NE", INTRINSIC_NE_OS),
minit (">", INTRINSIC_GT),
minit ("GT", INTRINSIC_GT_OS),
minit (">=", INTRINSIC_GE),
minit ("GE", INTRINSIC_GE_OS),
minit ("<", INTRINSIC_LT),
minit ("LT", INTRINSIC_LT_OS),
minit ("<=", INTRINSIC_LE),
minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
minit (NULL, -1)
@ -2734,11 +2740,17 @@ mio_expr (gfc_expr **ep)
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
mio_expr (&e->value.op.op1);
mio_expr (&e->value.op.op2);
break;

View File

@ -2715,14 +2715,18 @@ resolve_operator (gfc_expr *e)
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;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
@ -2732,7 +2736,9 @@ resolve_operator (gfc_expr *e)
/* Fall through... */
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_LOGICAL;
@ -2752,7 +2758,7 @@ resolve_operator (gfc_expr *e)
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.",
e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
gfc_op2string (e->value.op.operator));
else
sprintf (msg,
@ -2799,11 +2805,17 @@ resolve_operator (gfc_expr *e)
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (op1->rank == 0 && op2->rank == 0)
e->rank = 0;
@ -6691,6 +6703,29 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
}
}
}
/* PUBLIC interfaces may expose PRIVATE procedures that take types
PRIVATE to the containing module. */
for (iface = sym->generic; iface; iface = iface->next)
{
for (arg = iface->sym->formal; arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access (arg->sym->ts.derived->attr.access,
arg->sym->ts.derived->ns->default_access))
{
gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
"dummy arguments of '%s' which is PRIVATE",
iface->sym->name, sym->name, &iface->sym->declared_at,
gfc_typename(&arg->sym->ts));
/* Stop this message from recurring. */
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
}
}
/* An external symbol may not have an initializer because it is taken to be

View File

@ -1102,6 +1102,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
/* 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_EQ_OS:
case INTRINSIC_EQV:
code = EQ_EXPR;
checkstring = 1;
@ -1109,6 +1110,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
case INTRINSIC_NEQV:
code = NE_EXPR;
checkstring = 1;
@ -1116,24 +1118,28 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
code = GT_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
code = GE_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
code = LT_EXPR;
checkstring = 1;
lop = 1;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
code = LE_EXPR;
checkstring = 1;
lop = 1;

View File

@ -1,3 +1,11 @@
2007-07-08 Daniel Franke <franke.daniel@gmail.com>
PR fortran/17711
* gfortran.dg/operator_4.f90: New test.
* gfortran.dg/operator_5.f90: New test.
* gfortran.dg/logical_comp.f90: Adjusted error messages.
* gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
2007-07-08 Tobias Burnus <burnus@net-b.de>
PR fortran/32669

View File

@ -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

View File

@ -10,5 +10,5 @@ program test
use foo
print *, pi
end program test
! { dg-final { scan-module "foo" "MD5:1a6374d65e99c0175c42016a649f79db" } }
! { dg-final { scan-module "foo" "MD5:22d65c2e261759ab63cb7db9d0a8882b" } }
! { dg-final { cleanup-modules "foo" } }

View File

@ -0,0 +1,100 @@
! PR 17711 : Verify error message text meets operator in source
! { dg-do compile }
MODULE mod_t
type :: t
integer :: x
end type
INTERFACE OPERATOR(==)
MODULE PROCEDURE t_eq
END INTERFACE
INTERFACE OPERATOR(/=)
MODULE PROCEDURE t_ne
END INTERFACE
INTERFACE OPERATOR(>)
MODULE PROCEDURE t_gt
END INTERFACE
INTERFACE OPERATOR(>=)
MODULE PROCEDURE t_ge
END INTERFACE
INTERFACE OPERATOR(<)
MODULE PROCEDURE t_lt
END INTERFACE
INTERFACE OPERATOR(<=)
MODULE PROCEDURE t_le
END INTERFACE
CONTAINS
LOGICAL FUNCTION t_eq(this, other)
TYPE(t), INTENT(in) :: this, other
t_eq = (this%x == other%x)
END FUNCTION
LOGICAL FUNCTION t_ne(this, other)
TYPE(t), INTENT(in) :: this, other
t_ne = (this%x /= other%x)
END FUNCTION
LOGICAL FUNCTION t_gt(this, other)
TYPE(t), INTENT(in) :: this, other
t_gt = (this%x > other%x)
END FUNCTION
LOGICAL FUNCTION t_ge(this, other)
TYPE(t), INTENT(in) :: this, other
t_ge = (this%x >= other%x)
END FUNCTION
LOGICAL FUNCTION t_lt(this, other)
TYPE(t), INTENT(in) :: this, other
t_lt = (this%x < other%x)
END FUNCTION
LOGICAL FUNCTION t_le(this, other)
TYPE(t), INTENT(in) :: this, other
t_le = (this%x <= other%x)
END FUNCTION
END MODULE
PROGRAM pr17711
USE mod_t
LOGICAL :: A
INTEGER :: B
TYPE(t) :: C
A = (A == B) ! { dg-error "comparison operator '=='" }
A = (A.EQ.B) ! { dg-error "comparison operator '.eq.'" }
A = (A /= B) ! { dg-error "comparison operator '/='" }
A = (A.NE.B) ! { dg-error "comparison operator '.ne.'" }
A = (A <= B) ! { dg-error "comparison operator '<='" }
A = (A.LE.B) ! { dg-error "comparison operator '.le.'" }
A = (A < B) ! { dg-error "comparison operator '<'" }
A = (A.LT.B) ! { dg-error "comparison operator '.lt.'" }
A = (A >= B) ! { dg-error "comparison operator '>='" }
A = (A.GE.B) ! { dg-error "comparison operator '.ge.'" }
A = (A > B) ! { dg-error "comparison operator '>'" }
A = (A.GT.B) ! { dg-error "comparison operator '.gt.'" }
! this should also work with user defined operators
A = (A == C) ! { dg-error "comparison operator '=='" }
A = (A.EQ.C) ! { dg-error "comparison operator '.eq.'" }
A = (A /= C) ! { dg-error "comparison operator '/='" }
A = (A.NE.C) ! { dg-error "comparison operator '.ne.'" }
A = (A <= C) ! { dg-error "comparison operator '<='" }
A = (A.LE.C) ! { dg-error "comparison operator '.le.'" }
A = (A < C) ! { dg-error "comparison operator '<'" }
A = (A.LT.C) ! { dg-error "comparison operator '.lt.'" }
A = (A >= C) ! { dg-error "comparison operator '>='" }
A = (A.GE.C) ! { dg-error "comparison operator '.ge.'" }
A = (A > C) ! { dg-error "comparison operator '>'" }
A = (A.GT.C) ! { dg-error "comparison operator '.gt.'" }
END PROGRAM
! { dg-final { cleanup-modules "mod_t" } }

View File

@ -0,0 +1,51 @@
! { dg-do compile }
! { dg-options "-c" }
MODULE mod_t
type :: t
integer :: x
end type
! user defined operator
INTERFACE OPERATOR(.FOO.)
MODULE PROCEDURE t_foo
END INTERFACE
INTERFACE OPERATOR(.FOO.)
MODULE PROCEDURE t_foo ! { dg-error "already present" }
END INTERFACE
INTERFACE OPERATOR(.FOO.)
MODULE PROCEDURE t_bar ! { dg-error "Ambiguous interfaces" }
END INTERFACE
! intrinsic operator
INTERFACE OPERATOR(==)
MODULE PROCEDURE t_foo
END INTERFACE
INTERFACE OPERATOR(.eq.)
MODULE PROCEDURE t_foo ! { dg-error "already present" }
END INTERFACE
INTERFACE OPERATOR(==)
MODULE PROCEDURE t_bar ! { dg-error "Ambiguous interfaces" }
END INTERFACE
INTERFACE OPERATOR(.eq.)
MODULE PROCEDURE t_bar ! { dg-error "already present" }
END INTERFACE
CONTAINS
LOGICAL FUNCTION t_foo(this, other)
TYPE(t), INTENT(in) :: this, other
t_foo = .FALSE.
END FUNCTION
LOGICAL FUNCTION t_bar(this, other)
TYPE(t), INTENT(in) :: this, other
t_bar = .FALSE.
END FUNCTION
END MODULE
! { dg-final { cleanup-modules "mod_t" } }