@@ -4137,15 +4137,23 @@ convert_to_numeric (gfc_expr *a, gfc_expr *b)
}
/* Resolve an operator expression node. This can involve replacing the
- operation with a user defined function call. */
+ operation with a user defined function call. CHECK_INTERFACES is a
+ helper macro. */
+
+#define CHECK_INTERFACES \
+ { \
+ match m = gfc_extend_expr (e); \
+ if (m == MATCH_YES) \
+ return true; \
+ if (m == MATCH_ERROR) \
+ return false; \
+ }
static bool
resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
/* One error uses 3 names; additional space for wording (also via gettext). */
- char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50];
- bool dual_locus_error;
bool t = true;
/* Reduce stacked parentheses to single pair */
@@ -4195,8 +4203,6 @@ resolve_operator (gfc_expr *e)
if (t == false)
return false;
- dual_locus_error = false;
-
/* op1 and op2 cannot both be BOZ. */
if (op1 && op1->ts.type == BT_BOZ
&& op2 && op2->ts.type == BT_BOZ)
@@ -4210,9 +4216,9 @@ resolve_operator (gfc_expr *e)
if ((op1 && op1->expr_type == EXPR_NULL)
|| (op2 && op2->expr_type == EXPR_NULL))
{
- snprintf (msg, sizeof (msg),
- _("Invalid context for NULL() pointer at %%L"));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Invalid context for NULL() pointer at %L", &e->where);
+ return false;
}
switch (e->value.op.op)
@@ -4227,10 +4233,10 @@ resolve_operator (gfc_expr *e)
break;
}
- snprintf (msg, sizeof (msg),
- _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
- gfc_op2string (e->value.op.op), gfc_typename (e));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Operand of unary numeric operator %<%s%> at %L is %s",
+ gfc_op2string (e->value.op.op), &e->where, gfc_typename (e));
+ return false;
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
@@ -4244,10 +4250,10 @@ resolve_operator (gfc_expr *e)
Defer to a possibly overloading user-defined operator. */
if (!gfc_op_rank_conformable (op1, op2))
{
- dual_locus_error = true;
- snprintf (msg, sizeof (msg),
- _("Inconsistent ranks for operator at %%L and %%L"));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Inconsistent ranks for operator at %L and %L",
+ &op1->where, &op2->where);
+ return false;
}
gfc_type_convert_binary (e, 1);
@@ -4255,16 +4261,21 @@ resolve_operator (gfc_expr *e)
}
if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED)
- snprintf (msg, sizeof (msg),
- _("Unexpected derived-type entities in binary intrinsic "
- "numeric operator %%<%s%%> at %%L"),
- gfc_op2string (e->value.op.op));
+ {
+ CHECK_INTERFACES
+ gfc_error ("Unexpected derived-type entities in binary intrinsic "
+ "numeric operator %<%s%> at %L",
+ gfc_op2string (e->value.op.op), &e->where);
+ return false;
+ }
else
- snprintf (msg, sizeof(msg),
- _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (op1),
- gfc_typename (op2));
- goto bad_op;
+ {
+ CHECK_INTERFACES
+ gfc_error ("Operands of binary numeric operator %<%s%> at %L are %s/%s",
+ gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
+ gfc_typename (op2));
+ return false;
+ }
case INTRINSIC_CONCAT:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
@@ -4275,10 +4286,10 @@ resolve_operator (gfc_expr *e)
break;
}
- snprintf (msg, sizeof (msg),
- _("Operands of string concatenation operator at %%L are %s/%s"),
- gfc_typename (op1), gfc_typename (op2));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Operands of string concatenation operator at %L are %s/%s",
+ &e->where, gfc_typename (op1), gfc_typename (op2));
+ return false;
case INTRINSIC_AND:
case INTRINSIC_OR:
@@ -4318,12 +4329,11 @@ resolve_operator (gfc_expr *e)
goto simplify_op;
}
- snprintf (msg, sizeof (msg),
- _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (op1),
- gfc_typename (op2));
-
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Operands of logical operator %<%s%> at %L are %s/%s",
+ gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
+ gfc_typename (op2));
+ return false;
case INTRINSIC_NOT:
/* Logical ops on integers become bitwise ops with -fdec. */
@@ -4342,9 +4352,10 @@ resolve_operator (gfc_expr *e)
break;
}
- snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"),
- gfc_typename (op1));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Operand of .not. operator at %L is %s", &e->where,
+ gfc_typename (op1));
+ return false;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
@@ -4356,8 +4367,9 @@ resolve_operator (gfc_expr *e)
case INTRINSIC_LE_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
- strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("COMPLEX quantities cannot be compared at %L", &e->where);
+ return false;
}
/* Fall through. */
@@ -4427,10 +4439,10 @@ resolve_operator (gfc_expr *e)
Defer to a possibly overloading user-defined operator. */
if (!gfc_op_rank_conformable (op1, op2))
{
- dual_locus_error = true;
- snprintf (msg, sizeof (msg),
- _("Inconsistent ranks for operator at %%L and %%L"));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Inconsistent ranks for operator at %L and %L",
+ &op1->where, &op2->where);
+ return false;
}
gfc_type_convert_binary (e, 1);
@@ -4464,18 +4476,22 @@ resolve_operator (gfc_expr *e)
}
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
- snprintf (msg, sizeof (msg),
- _("Logicals at %%L must be compared with %s instead of %s"),
- (e->value.op.op == INTRINSIC_EQ
- || e->value.op.op == INTRINSIC_EQ_OS)
- ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
+ {
+ CHECK_INTERFACES
+ gfc_error ("Logicals at %L must be compared with %s instead of %s",
+ &e->where,
+ (e->value.op.op == INTRINSIC_EQ || e->value.op.op == INTRINSIC_EQ_OS)
+ ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
+ }
else
- snprintf (msg, sizeof (msg),
- _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
- gfc_op2string (e->value.op.op), gfc_typename (op1),
- gfc_typename (op2));
+ {
+ CHECK_INTERFACES
+ gfc_error ("Operands of comparison operator %<%s%> at %L are %s/%s",
+ gfc_op2string (e->value.op.op), &e->where, gfc_typename (op1),
+ gfc_typename (op2));
+ }
- goto bad_op;
+ return false;
case INTRINSIC_USER:
if (e->value.op.uop->op == NULL)
@@ -4483,28 +4499,29 @@ resolve_operator (gfc_expr *e)
const char *name = e->value.op.uop->name;
const char *guessed;
guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ CHECK_INTERFACES
if (guessed)
- snprintf (msg, sizeof (msg),
- _("Unknown operator %%<%s%%> at %%L; did you mean "
- "%%<%s%%>?"), name, guessed);
+ gfc_error ("Unknown operator %<%s%> at %L; did you mean "
+ "%<%s%>?", name, &e->where, guessed);
else
- snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"),
- name);
+ gfc_error ("Unknown operator %<%s%> at %L", name, &e->where);
}
else if (op2 == NULL)
- snprintf (msg, sizeof (msg),
- _("Operand of user operator %%<%s%%> at %%L is %s"),
- e->value.op.uop->name, gfc_typename (op1));
+ {
+ CHECK_INTERFACES
+ gfc_error ("Operand of user operator %<%s%> at %L is %s",
+ e->value.op.uop->name, &e->where, gfc_typename (op1));
+ }
else
{
- snprintf (msg, sizeof (msg),
- _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (op1),
- gfc_typename (op2));
e->value.op.uop->op->sym->attr.referenced = 1;
+ CHECK_INTERFACES
+ gfc_error ("Operands of user operator %<%s%> at %L are %s/%s",
+ e->value.op.uop->name, &e->where, gfc_typename (op1),
+ gfc_typename (op2));
}
- goto bad_op;
+ return false;
case INTRINSIC_PARENTHESES:
e->ts = op1->ts;
@@ -4582,10 +4599,10 @@ resolve_operator (gfc_expr *e)
e->rank = 0;
/* Try user-defined operators, and otherwise throw an error. */
- dual_locus_error = true;
- snprintf (msg, sizeof (msg),
- _("Inconsistent ranks for operator at %%L and %%L"));
- goto bad_op;
+ CHECK_INTERFACES
+ gfc_error ("Inconsistent ranks for operator at %L and %L",
+ &op1->where, &op2->where);
+ return false;
}
}
@@ -4620,23 +4637,6 @@ simplify_op:
t = true;
}
return t;
-
-bad_op:
-
- {
- match m = gfc_extend_expr (e);
- if (m == MATCH_YES)
- return true;
- if (m == MATCH_ERROR)
- return false;
- }
-
- if (dual_locus_error)
- gfc_error (msg, &op1->where, &op2->where);
- else
- gfc_error (msg, &e->where);
-
- return false;
}
Hi all, The attached patch changes all the snprintf calls to regular gfc_error calls to cleanup translation. I introduced a simple macro to facilitate doing the checks that were being done in the bad_op code section. From the description for the call to gfc_extend_expr interfaces are mentioned so I used the CHECK_INTERFACES name for the macro. Regression tested on linux-x86_64. No new test cases. OK for mainline? Backport? Regards, Jerry Author: Jerry DeLisle <jvdelisle@gcc.gnu.org> Date: Tue Aug 6 12:47:30 2024 -0700 Fortran: Eliminate error prone translations. PR fortran/109105 gcc/fortran/ChangeLog: * resolve.cc (CHECK_INTERFACES): New helper macro. (resolve_operator): Replace use of snprintf with gfc_error.