switch (code)
{
case ARITH_OK:
- p = _("Arithmetic OK");
+ p = _("Arithmetic OK at %L");
break;
case ARITH_OVERFLOW:
- p = _("Arithmetic overflow");
+ p = _("Arithmetic overflow at %L");
break;
case ARITH_UNDERFLOW:
- p = _("Arithmetic underflow");
+ p = _("Arithmetic underflow at %L");
break;
case ARITH_NAN:
- p = _("Arithmetic NaN");
+ p = _("Arithmetic NaN at %L");
break;
case ARITH_DIV0:
- p = _("Division by zero");
+ p = _("Division by zero at %L");
break;
case ARITH_INCOMMENSURATE:
- p = _("Array operands are incommensurate");
+ p = _("Array operands are incommensurate at %L");
break;
case ARITH_ASYMMETRIC:
- p = _("Integer outside symmetric range implied by Standard Fortran");
+ p =
+ _("Integer outside symmetric range implied by Standard Fortran at %L");
break;
default:
gfc_internal_error ("gfc_arith_error(): Bad error code");
if (val == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+ gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (val == ARITH_ASYMMETRIC)
{
- gfc_warning ("%s at %L", gfc_arith_error (val), &x->where);
+ gfc_warning (gfc_arith_error (val), &x->where);
val = ARITH_OK;
}
if (rc != ARITH_OK)
{ /* Something went wrong */
- gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where);
+ gfc_error (gfc_arith_error (rc), &op1->where);
return NULL;
}
static void
arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where)
{
- gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc),
- gfc_typename (from), gfc_typename (to), where);
+ switch (rc)
+ {
+ case ARITH_OK:
+ gfc_error ("Arithmetic OK converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_OVERFLOW:
+ gfc_error ("Arithmetic overflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_UNDERFLOW:
+ gfc_error ("Arithmetic underflow converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_NAN:
+ gfc_error ("Arithmetic NaN converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_DIV0:
+ gfc_error ("Division by zero converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_INCOMMENSURATE:
+ gfc_error ("Array operands are incommensurate converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ case ARITH_ASYMMETRIC:
+ gfc_error ("Integer outside symmetric range implied by Standard Fortran"
+ " converting %s to %s at %L",
+ gfc_typename (from), gfc_typename (to), where);
+ break;
+ default:
+ gfc_internal_error ("gfc_arith_error(): Bad error code");
+ }
/* TODO: Do something about the error, ie, throw exception, return
NaN, etc. */
{
if (rc == ARITH_ASYMMETRIC)
{
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
}
else
{
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
}
if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.r, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
if (rc == ARITH_UNDERFLOW)
{
if (gfc_option.warn_underflow)
- gfc_warning ("%s at %L", gfc_arith_error (rc), &src->where);
+ gfc_warning (gfc_arith_error (rc), &src->where);
mpfr_set_ui (result->value.complex.i, 0, GFC_RND_MODE);
}
else if (rc != ARITH_OK)
#include "intrinsic.h"
-/* The fundamental complaint function of this source file. This
- function can be called in all kinds of ways. */
-
-static void
-must_be (gfc_expr * e, int n, const char *thing_msgid)
-{
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
- gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
- thing_msgid);
-}
-
-
/* Check the type of an expression. */
static try
if (e->ts.type == type)
return SUCCESS;
- must_be (e, n, gfc_basic_typename (type));
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
+ gfc_basic_typename (type));
return FAILURE;
}
if (gfc_numeric_ts (&e->ts))
return SUCCESS;
- must_be (e, n, "a numeric type");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
{
if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL)
{
- must_be (e, n, "INTEGER or REAL");
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
{
if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX)
{
- must_be (e, n, "REAL or COMPLEX");
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be REAL or COMPLEX",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
if (k->expr_type != EXPR_CONSTANT)
{
- must_be (k, n, "a constant");
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be a constant",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
return FAILURE;
}
if (d->ts.kind != gfc_default_double_kind)
{
- must_be (d, n, "double precision");
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be double precision",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
return FAILURE;
}
{
if (array->ts.type != BT_LOGICAL || array->rank == 0)
{
- must_be (array, n, "a logical array");
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be a logical array",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
return FAILURE;
}
if (e->rank != 0)
return SUCCESS;
- must_be (e, n, "an array");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
if (e->rank == 0)
return SUCCESS;
- must_be (e, n, "a scalar");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
static try
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
{
- char message[100];
-
if (gfc_compare_types (&e->ts, &f->ts))
return SUCCESS;
- sprintf (message, _("the same type and kind as '%s'"),
- gfc_current_intrinsic_arg[n]);
-
- must_be (f, m, message);
-
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
+ "and kind as '%s'", gfc_current_intrinsic_arg[m],
+ gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
return FAILURE;
}
static try
rank_check (gfc_expr * e, int n, int rank)
{
- char message[100];
-
if (e->rank == rank)
return SUCCESS;
- sprintf (message, _("of rank %d"), rank);
-
- must_be (e, n, message);
-
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ &e->where, rank);
return FAILURE;
}
static try
kind_value_check (gfc_expr * e, int n, int k)
{
- char message[100];
-
if (e->ts.kind == k)
return SUCCESS;
- sprintf (message, _("of kind %d"), k);
-
- must_be (e, n, message);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
+ &e->where, k);
return FAILURE;
}
return FAILURE;
}
- must_be (e, n, "a variable");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
+ gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);
return FAILURE;
}
if (!array->symtree->n.sym->attr.allocatable)
{
- must_be (array, 0, "ALLOCATABLE");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &array->where);
return FAILURE;
}
attr = gfc_variable_attr (pointer, NULL);
if (!attr.pointer)
{
- must_be (pointer, 0, "a POINTER");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
+ &pointer->where);
return FAILURE;
}
attr = gfc_variable_attr (target, NULL);
if (!attr.pointer && !attr.target)
{
- must_be (target, 1, "a POINTER or a TARGET");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
+ "or a TARGET", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &target->where);
return FAILURE;
}
if (x->ts.type == BT_COMPLEX)
{
- must_be (y, 1, "not be present if 'x' is COMPLEX");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+ "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
return FAILURE;
}
}
if (x->ts.type == BT_COMPLEX)
{
- must_be (y, 1, "not be present if 'x' is COMPLEX");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
+ "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &y->where);
return FAILURE;
}
}
break;
default:
- must_be (vector_a, 0, "numeric or LOGICAL");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ "or LOGICAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &vector_a->where);
return FAILURE;
}
if (string->ts.kind != substring->ts.kind)
{
- must_be (substring, 1, "the same kind as 'string'");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
+ "kind as '%s'", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &substring->where,
+ gfc_current_intrinsic_arg[0]);
return FAILURE;
}
{
if (x->ts.type == BT_DERIVED)
{
- must_be (x, 0, "a non-derived type");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
+ "non-derived type", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
return FAILURE;
}
{
if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
{
- must_be (matrix_a, 0, "numeric or LOGICAL");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ "or LOGICAL", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &matrix_a->where);
return FAILURE;
}
if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
{
- must_be (matrix_b, 0, "numeric or LOGICAL");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
+ "or LOGICAL", gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic, &matrix_b->where);
return FAILURE;
}
break;
default:
- must_be (matrix_a, 0, "of rank 1 or 2");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank "
+ "1 or 2", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &matrix_a->where);
return FAILURE;
}
if (!attr.pointer)
{
- must_be (mold, 0, "a POINTER");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &mold->where);
return FAILURE;
}
if (mask->rank != 0 && mask->rank != array->rank)
{
- must_be (array, 0, "conformable with 'mask' argument");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
+ "with '%s' argument", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &array->where,
+ gfc_current_intrinsic_arg[1]);
return FAILURE;
}
{
if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX)
{
- must_be (x, 0, "of type REAL or COMPLEX");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of type "
+ "REAL or COMPLEX", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &x->where);
return FAILURE;
}
sym = a->symtree->n.sym;
if (!sym->attr.dummy)
{
- must_be (a, 0, "a dummy variable");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
+ "dummy variable", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
return FAILURE;
}
if (!sym->attr.optional)
{
- must_be (a, 0, "an OPTIONAL dummy variable");
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
+ "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &a->where);
return FAILURE;
}
{
if (source->rank >= GFC_MAX_DIMENSIONS)
{
- char message[100];
-
- sprintf (message, _("less than rank %d"), GFC_MAX_DIMENSIONS);
- must_be (source, 0, message);
+ gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
+ "than rank %d", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);
return FAILURE;
}