procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Eliminate error prone translations.

Browse source 
PR fortran/109105

gcc/fortran/ChangeLog:

	* resolve.cc (CHECK_INTERFACES): New helper macro.
	(resolve_operator): Replace use of snprintf with
	gfc_error.
This commit is contained in:
Jerry DeLisle 2024-08-06 16:10:23 -07:00
parent d4b35dab72
commit 000045fdf8
1 changed files with 88 additions and 88 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

176
gcc/fortran/resolve.cc
View file

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