OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/fortran/ChangeLog
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

41
gcc/fortran/arith.c
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);
}

12
gcc/fortran/arith.h
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 *);

8
gcc/fortran/dump-parse-tree.c
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:

28
gcc/fortran/expr.c
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;

10
gcc/fortran/gfortran.h
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;

185
gcc/fortran/interface.c
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)
if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
interface_name, true))
break;
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)
{
sym = gfc_search_interface (ns->operator[i], 0, &actual);
/* 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)
return 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;

12
gcc/fortran/match.c
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),

22
gcc/fortran/matchexp.c
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:

24
gcc/fortran/module.c
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;

39
gcc/fortran/resolve.c
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

6
gcc/fortran/trans-expr.c
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;

8
gcc/testsuite/ChangeLog
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

4
gcc/testsuite/gfortran.dg/logical_comp.f90
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

2
gcc/testsuite/gfortran.dg/module_md5_1.f90
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" } }

100
gcc/testsuite/gfortran.dg/operator_4.f90 Normal file
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" } }

51
gcc/testsuite/gfortran.dg/operator_5.f90 Normal file
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" } }